diff --git a/.gitignore b/.gitignore
index a27c2eff..d41b0114 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,20 @@
 /.lake
-/result
+/result*
 /.direnv
 # Keep scratch plans local while versioning the authoritative execution ladder.
 /plans/*
 !/plans/roadmap.md
+!/plans/l4l-15-structure-eta-design.md
+!/plans/l4l-16-sort-inversion-decision.md
+!/plans/l4l-18b-extension-interface-design.md
+!/plans/l4l-16-completion-plan.md
+!/plans/l4l-16c-adequacy-log.md
+!/plans/l4l-16c-buildp-premortem.md
+!/plans/l4l-16d0-slice-map.md
+!/plans/l4l-16e-promotion-map.md
+!/plans/l4l-16-weakn-design.md
+!/plans/l4l-16-generic-instance-design.md
+!/plans/l4l-18a-prime-scope.md
+!/plans/l4l-16-stratified-observation-design.md
+!/plans/l4l-16-registered-pi-design.md
+!/plans/l4l-16-typedview-design.md
diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean
index c5be36d3..2d2806c1 100644
--- a/Lean4Lean/Audit/SorryFrontier.lean
+++ b/Lean4Lean/Audit/SorryFrontier.lean
@@ -2,8 +2,11 @@ import Lean4Lean.Theory
 import Lean4Lean.Theory.ConstructorValidityFixtures
 import Lean4Lean.Theory.Inductive
 import Lean4Lean.Theory.InductiveFixtures
+import Lean4Lean.Theory.Literals
+import Lean4Lean.Theory.LocalContext
 import Lean4Lean.Theory.Meta
 import Lean4Lean.Theory.MutualInductiveFixtures
+import Lean4Lean.Theory.Projection
 import Lean4Lean.Theory.Quot
 import Lean4Lean.Theory.SingletonParity
 import Lean4Lean.Theory.Typing.Basic
@@ -11,6 +14,7 @@ import Lean4Lean.Theory.Typing.ChurchRosser
 import Lean4Lean.Theory.Typing.Env
 import Lean4Lean.Theory.Typing.EnvLemmas
 import Lean4Lean.Theory.Typing.HeadReduction
+import Lean4Lean.Theory.Typing.InductiveCertificate
 import Lean4Lean.Theory.Typing.InductiveLemmas
 import Lean4Lean.Theory.Typing.Injectivity
 import Lean4Lean.Theory.Typing.Lemmas
@@ -31,6 +35,7 @@ import Lean4Lean.Verify.Environment.CandidateIdentityReplay
 import Lean4Lean.Verify.Environment.ConstructorValidation
 import Lean4Lean.Verify.Environment.ConstructorValidityMatrix
 import Lean4Lean.Verify.Environment.ConstructorValidityReplay
+import Lean4Lean.Verify.Environment.DeepNestedReplay
 import Lean4Lean.Verify.Environment.Elimination
 import Lean4Lean.Verify.Environment.EliminationFixtures
 import Lean4Lean.Verify.Environment.EliminationFixturesCommon
@@ -46,6 +51,7 @@ import Lean4Lean.Verify.Environment.IndexedVecConstructors
 import Lean4Lean.Verify.Environment.IndexedVecOuterReplay
 import Lean4Lean.Verify.Environment.IndexedVecSemanticReplay
 import Lean4Lean.Verify.Environment.InductiveFixtures
+import Lean4Lean.Verify.Environment.InductiveReplayMatrix
 import Lean4Lean.Verify.Environment.Lemmas
 import Lean4Lean.Verify.Environment.MutualInductiveFixtures
 import Lean4Lean.Verify.Environment.Normalization
@@ -81,7 +87,7 @@ token), so it can never drift from Lean's lexer over comments, string/char
 literals, or nested block comments. Attribution is by SOURCE MODULE via
 `getModuleIdxFor?`, so a declaration is charged to the file that defines it even
 when it sits in a foreign namespace (e.g. `Lean.Level.isEquiv_wf` lives in
-`Lean4Lean.Verify.Level`).
+`Lean4Lean.Verify.LevelStd`).
 
 The audited surface is exactly the modules reachable from this file's imports:
 importing a `Theory`/`Verify` module here is what brings it into scope. A sorry
@@ -126,30 +132,46 @@ private def surfacePrefixes : Array Lean.Name := #[`Lean4Lean.Theory, `Lean4Lean
 S (missing specification), P (stated but sorried, blocked on S), V (checker
 verification, blocked on S/P), R (research-grade metatheory, upstream-driven). -/
 private def allowlist : Array Lean.Name := #[
-  -- Tier S — missing specification
-  `Lean4Lean.TrProj,
-  -- Tier P — blocked only on Tier S
-  `Lean4Lean.TrProj.weak',
-  `Lean4Lean.TrProj.weak'_inv,
-  `Lean4Lean.TrProj.defeqDFC,
-  `Lean4Lean.TrProj.wf,
-  `Lean4Lean.TrProj.uniq,
-  `Lean4Lean.TrProj.instN,
-  `Lean4Lean.TrProj.instL,
-  -- Tier V — checker verification, blocked on Tiers S/P
-  -- (NormLevel.subsumption_eval and Level.isEquiv_wf were proved on the
-  -- formalization line, 2026-08-05/07, and left the frontier.)
+  -- Tier V — checker verification, blocked on Tier P
+  -- (NormLevel.subsumption_eval and the primed-comparator soundness were
+  -- proved on the formalization line, 2026-08-05/07, and left the frontier;
+  -- the v4.33 reconciliation then absorbed upstream's stronger level
+  -- verification.)
+  -- After upstream #28 (v4.33 reconciliation), `addDecl.WF` is proved for
+  -- every declaration kind except `inductDecl`, whose case is the remaining
+  -- sorry (L4L-19B territory).
   `Lean4Lean.addDecl.WF,
-  `Lean4Lean.TypeChecker.Inner.inferProj.WF,
+  -- Upstream's front-end trust boundary for the syntactic primitive-definition
+  -- recognizer (Verify/Environment/Boundaries.lean), added by #28 at the
+  -- v4.33 reconciliation.
+  `Lean4Lean.checkPrimitiveDef.WF,
+  -- `ProjectionReady`/registered `StructureEtaReady` transport across the
+  -- front-end environment extensions (Verify/Environment/Extension.lean):
+  -- upstream's proved v4.33 declaration chains do not establish these fork
+  -- obligations on `VContext`; the transport proofs are L4L-19B content. The
+  -- mutual-block entry is the compiled recursive functional of
+  -- `VEnvAt.addAxioms`.
+  `Lean4Lean.VEnvAt.addAxioms._f,
+  `Lean4Lean.addConstCore.WF,
+  `Lean4Lean.addDef.WF,
+  `Lean4Lean.addMutualBlock.WF,
+  `Lean4Lean.addUnsafeDef.WF,
+  -- Quotient initialization (Verify/Environment.lean): upstream's v4.33
+  -- proof was vacuous via the fork-refutable `TrEnv'.no_inductInfo`; the
+  -- constructive connection to the Theory quotient transaction is L4L-19B
+  -- content.
+  `Lean4Lean.addQuot.WF,
+  -- v4.33 reconciliation repair debt: the exact alignment-run fixture's
+  -- `build.eq_def` stepping no longer elaborates; the closed checker-run
+  -- statement is unchanged (Verify/Environment/InductiveFixtures.lean).
+  `Lean4Lean.InductiveReplayFixtures.aliasFormerAlignmentRun,
   `Lean4Lean.TypeChecker.Inner.reduceRecursor.WF,
-  `Lean4Lean.TypeChecker.Inner.reduceProj.WF,
-  `Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF,
-  `Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF,
   -- Tier R — research-grade metatheory (upstream-driven, not scheduled)
   `Lean4Lean.VEnv.IsDefEqU.sort_inv,
   `Lean4Lean.VEnv.IsDefEqU.forallE_inv_stratified,
   `Lean4Lean.VEnv.IsDefEqU.sort_forallE_inv,
   `Lean4Lean.VEnv.IsDefEqU.weakN_iff,
+  `Lean4Lean.VEnv.WF.registeredStructureHeadInversion,
   `Lean4Lean.VEnv.NormalEq.parRed,
   -- Tier F — deliberately kernel-rejected inductive fixtures. Elaborator error
   -- recovery admits the invalid `inductive` with `sorryAx`, so the constant
diff --git a/Lean4Lean/Environment.lean b/Lean4Lean/Environment.lean
index 226ebd49..bd885361 100644
--- a/Lean4Lean/Environment.lean
+++ b/Lean4Lean/Environment.lean
@@ -31,22 +31,21 @@ def addDefinition (env : Environment) (v : DefinitionVal)
     if check then
       _ ← (checkConstantVal env v.toConstantVal).run env
         (safety := .unsafe) (lparams := v.levelParams) (fuel := fuel)
-    let env' := env.add (.defnInfo v)
+    let env' := env.add (.axiomInfo { v with isUnsafe := true })
     if check then
       checkNoMVarNoFVar env' v.name v.value
       M.run env' (safety := .unsafe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do
         let valType ← TypeChecker.checkType v.value
         if !(← isDefEq valType v.type) then
           throw <| .declTypeMismatch env' (.defnDecl v) valType
-    return env'
-  else
-    if check then
-      M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do
-        checkConstantVal env v.toConstantVal (← checkPrimitiveDef v)
-        let valType ← TypeChecker.checkType v.value
-        if !(← isDefEq valType v.type) then
-          throw <| .declTypeMismatch env (.defnDecl v) valType
-    return env.add (.defnInfo v)
+  else if check then
+    M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do
+      checkConstantVal env v.toConstantVal (← checkPrimitiveDef v)
+      checkNoMVarNoFVar env v.name v.value
+      let valType ← TypeChecker.checkType v.value
+      if !(← isDefEq valType v.type) then
+        throw <| .declTypeMismatch env (.defnDecl v) valType
+  return env.add (.defnInfo v)
 
 def addTheorem (env : Environment) (v : TheoremVal) (check := true) (fuel : FuelConfig := {}) :
     Except Exception Environment := do
@@ -56,6 +55,7 @@ def addTheorem (env : Environment) (v : TheoremVal) (check := true) (fuel : Fuel
       checkConstantVal env v.toConstantVal
       if !(← isProp v.type) then
         throw <| .thmTypeIsNotProp env v.name v.type
+      checkNoMVarNoFVar env v.name v.value
       let valType ← TypeChecker.checkType v.value
       if !(← isDefEq valType v.type) then
         throw <| .declTypeMismatch env (.thmDecl v) valType
@@ -66,6 +66,7 @@ def addOpaque (env : Environment) (v : OpaqueVal) (check := true) (fuel : FuelCo
   if check then
     M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do
       checkConstantVal env v.toConstantVal
+      checkNoMVarNoFVar env v.name v.value
       let valType ← TypeChecker.checkType v.value
       if !(← isDefEq valType v.type) then
         throw <| .declTypeMismatch env (.opaqueDecl v) valType
@@ -78,14 +79,22 @@ def addMutual (env : Environment) (vs : List DefinitionVal)
     throw <| .other "invalid mutual definition, declaration is not tagged as unsafe/partial"
   if check then
     M.run env (safety := v₀.safety) (lctx := {}) (lparams := v₀.levelParams) (fuel := fuel) do
+      let mut found : NameSet := {}
       for v in vs do
         if v.safety != v₀.safety then
           throw <| .other
             "invalid mutual definition, declarations must have the same safety annotation"
+        -- The whole block is checked under one set of level parameters, so they must agree;
+        -- lean4#14608 adds the same check to the C++ kernel.
+        if v.levelParams != v₀.levelParams then
+          throw <| .other
+            "invalid mutual definition, declarations must have the same universe level parameters"
+        if found.contains v.name then
+          throw <| .other s!"invalid mutual definition, duplicate declaration name '{v.name}'"
+        found := found.insert v.name
         checkConstantVal env v.toConstantVal
-  let mut env' := env
-  for v in vs do
-    env' := env'.add (.defnInfo v)
+  let env' := vs.foldl (init := env) fun env' v =>
+    env'.add (.axiomInfo { v with isUnsafe := v₀.safety == .unsafe })
   if check then
     M.run env' (safety := v₀.safety) (lctx := {}) (lparams := v₀.levelParams) (fuel := fuel) do
       for v in vs do
@@ -93,7 +102,7 @@ def addMutual (env : Environment) (vs : List DefinitionVal)
         let valType ← TypeChecker.checkType v.value
         if !(← isDefEq valType v.type) then
           throw <| .declTypeMismatch env' (.mutualDefnDecl vs) valType
-  return env'
+  return vs.foldl (fun env' v => env'.add (.defnInfo v)) env
 
 /-- Type check given declaration and add it to the environment -/
 def addDecl (env : Environment) (decl : Declaration) (check := true) (fuel : FuelConfig := {}) :
diff --git a/Lean4Lean/Environment/Basic.lean b/Lean4Lean/Environment/Basic.lean
index 7ed24cd0..44bfd3fb 100644
--- a/Lean4Lean/Environment/Basic.lean
+++ b/Lean4Lean/Environment/Basic.lean
@@ -51,6 +51,62 @@ def isNonRecStructure (env : Environment) (constName : Name) : Bool :=
   | some (.inductInfo { isRec := false, ctors := [_], numIndices := 0, .. }) => true
   | _ => false
 
+/-- A one-constructor, unindexed structure whose constructor and generated
+recursor have both reached the host environment.  Family metadata is staged
+before either artifact is inserted; projection verification may only demand a
+registered Theory view at this later boundary.
+
+Unlike `isNonRecStructure`, projection readiness deliberately does not inspect
+`InductiveVal.isRec`: Lean emits primitive projections for recursive structures
+too (including nested-recursive structures in the Lean prelude). -/
+def isProjectionReadyStructure (env : Environment) (constName : Name) : Bool :=
+  match env.constants.find?' constName with
+  | some (.inductInfo { ctors := [ctor], numIndices := 0, .. }) =>
+    match env.constants.find?' ctor,
+        env.constants.find?' (mkRecName constName) with
+    | some (.ctorInfo _), some (.recInfo _) => true
+    | _, _ => false
+  | _ => false
+
+theorem isProjectionReadyStructure_false_of_no_ctorInfo
+    {env : Environment} {name : Name} {info : InductiveVal}
+    (hfind : env.constants.find?' name = some (.inductInfo info))
+    (hnoCtor : ∀ ctor ctorInfo,
+      env.constants.find?' ctor ≠ some (.ctorInfo ctorInfo)) :
+    env.isProjectionReadyStructure name = false := by
+  cases info
+  rename_i constant numParams numIndices all ctors numNested isRec isUnsafe isReflexive
+  cases constant
+  unfold isProjectionReadyStructure
+  rw [hfind]
+  cases numIndices with
+  | succ _ => rfl
+  | zero =>
+    cases ctors with
+    | nil => rfl
+    | cons ctor rest =>
+      cases rest with
+      | cons _ _ => rfl
+      | nil =>
+        cases hctor : env.constants.find?' ctor with
+        | none => simp [hctor]
+        | some info =>
+          cases info <;> simp_all
+
+theorem isProjectionReadyStructure_false_of_numIndices_ne
+    {env : Environment} {name : Name} {info : InductiveVal}
+    (hfind : env.constants.find?' name = some (.inductInfo info))
+    (hindices : info.numIndices ≠ 0) :
+    env.isProjectionReadyStructure name = false := by
+  cases info
+  simp_all [isProjectionReadyStructure]
+
+theorem isProjectionReadyStructure_false_of_not_found
+    {env : Environment} {name : Name}
+    (hfind : env.constants.find?' name = none) :
+    env.isProjectionReadyStructure name = false := by
+  simp [isProjectionReadyStructure, hfind]
+
 def checkName (env : Environment) (n : Name)
     (allowPrimitive := false) : Except Exception Unit := do
   if env.contains n then
diff --git a/Lean4Lean/Experimental/DomainTheory.lean b/Lean4Lean/Experimental/DomainTheory.lean
index a20b2b95..6c036e41 100644
--- a/Lean4Lean/Experimental/DomainTheory.lean
+++ b/Lean4Lean/Experimental/DomainTheory.lean
@@ -41,7 +41,7 @@ inductive FinElem where
   | bot
   | val : SExprF FinElem (FinFun FinElem FinElem) → FinElem
 
-def DomN : Nat → Type
+@[implicit_reducible] def DomN : Nat → Type
   | 0 => Unit
   | n+1 => Option (SExprF (DomN n) (DomN n → DomN n))
 
@@ -176,7 +176,7 @@ theorem DomN.cast_eq (x : DomN (a + 1)) :
       simp [SExprF.map_comp]; congr 1 <;> ext t <;> simp [this]
       congr 2; exact DomN.cast_upN (k := 1) _ (Nat.le_add_right ..)
 
-def Dom : Type := { f : ∀ n, DomN n // ∀ n, f n = (f (n + 1)).down }
+@[implicit_reducible] def Dom : Type := { f : ∀ n, DomN n // ∀ n, f n = (f (n + 1)).down }
 
 def Dom.bot : Dom := ⟨fun | 0 => () | _+1 => none, fun | 0 | _+1 => rfl⟩
 
diff --git a/Lean4Lean/Experimental/MoreStepIndexed.lean b/Lean4Lean/Experimental/MoreStepIndexed.lean
index b533aa77..14430d01 100644
--- a/Lean4Lean/Experimental/MoreStepIndexed.lean
+++ b/Lean4Lean/Experimental/MoreStepIndexed.lean
@@ -66,7 +66,7 @@ inductive ShapeS (Shape : Type) (n : Nat) : Type where
   | forallE : Shape → List (Shape × Shape) → ShapeS Shape n
   | lam : List (Shape × Shape) → ShapeS Shape n
 
-def Shape : Nat → Type
+@[implicit_reducible] def Shape : Nat → Type
   | 0 => Unit -- bottom
   | n + 1 => ShapeS (Shape n) n
 
diff --git a/Lean4Lean/Experimental/ParallelReduction.lean b/Lean4Lean/Experimental/ParallelReduction.lean
index 187f4b27..54771ff5 100644
--- a/Lean4Lean/Experimental/ParallelReduction.lean
+++ b/Lean4Lean/Experimental/ParallelReduction.lean
@@ -1,905 +1,11 @@
 import Lean4Lean.Theory.Typing.Strong
 import Lean4Lean.Experimental.NormalEq
 
--- TODO: remove, this is now part of ChurchRosser.lean
-
--- TODO: remove, this is now part of ChurchRosser.lean
-
-namespace Lean4Lean
-
-open VExpr
-
-section
-set_option hygiene false
-variable (TY : Typing)
-local notation:65 Γ " ⊢ " e1 " ≫ " e2:30 => ParRed Γ e1 e2
-local notation:65 Γ " ⊢ " e1 " ⋙ " e2:30 => CParRed Γ e1 e2
-
-inductive ParRed : List VExpr → VExpr → VExpr → Prop where
-  | bvar : Γ ⊢ .bvar i ≫ .bvar i
-  | sort : Γ ⊢ .sort u ≫ .sort u
-  | const : Γ ⊢ .const c ls ≫ .const c ls
-  | app : Γ ⊢ f ≫ f' → Γ ⊢ a ≫ a' → Γ ⊢ .app f a ≫ .app f' a'
-  | lam : Γ ⊢ A ≫ A' → A::Γ ⊢ body ≫ body' → Γ ⊢ .lam A body ≫ .lam A' body'
-  | forallE : Γ ⊢ A ≫ A' → A::Γ ⊢ B ≫ B' → Γ ⊢ .forallE A B ≫ .forallE A' B'
-  | beta : A::Γ ⊢ e₁ ≫ e₁' → Γ ⊢ e₂ ≫ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ≫ e₁'.inst e₂'
-  | extra : TY.Pat p r → p.Matches e m1 m2 → r.2.OK (TY.IsDefEqU Γ) m1 m2 →
-    (∀ a, Γ ⊢ m2 a ≫ m2' a) → Γ ⊢ e ≫ r.1.apply m1 m2'
-
-def NonNeutral (TY : Typing) (Γ : List VExpr) (e : VExpr) : Prop :=
-  (∃ A e₁ e₂, e = .app (.lam A e₁) e₂) ∨
-  (∃ p r m1 m2, TY.Pat p r ∧ p.Matches e m1 m2 ∧ r.2.OK (TY.IsDefEqU Γ) m1 m2)
-
-inductive CParRed : List VExpr → VExpr → VExpr → Prop where
-  | bvar : Γ ⊢ .bvar i ⋙ .bvar i
-  | sort : Γ ⊢ .sort u ⋙ .sort u
-  | const : ¬NonNeutral TY Γ (.const c ls) → Γ ⊢ .const c ls ⋙ .const c ls
-  | app : ¬NonNeutral TY Γ (.app f a) → Γ ⊢ f ⋙ f' → Γ ⊢ a ⋙ a' → Γ ⊢ .app f a ⋙ .app f' a'
-  | lam : Γ ⊢ A ⋙ A' → A::Γ ⊢ body ⋙ body' → Γ ⊢ .lam A body ⋙ .lam A' body'
-  | forallE : Γ ⊢ A ⋙ A' → A::Γ ⊢ B ⋙ B' → Γ ⊢ .forallE A B ⋙ .forallE A' B'
-  | beta : A::Γ ⊢ e₁ ⋙ e₁' → Γ ⊢ e₂ ⋙ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ⋙ e₁'.inst e₂'
-  | extra : TY.Pat p r → p.Matches e m1 m2 → r.2.OK (TY.IsDefEqU Γ) m1 m2 →
-    (∀ a, Γ ⊢ m2 a ⋙ m2' a) → Γ ⊢ e ⋙ r.1.apply m1 m2'
-
-end
-
-variable {TY : Typing}
-
-protected theorem ParRed.rfl : ∀ {e}, ParRed TY Γ e e
-  | .bvar .. => .bvar
-  | .sort .. => .sort
-  | .const .. => .const
-  | .app .. => .app ParRed.rfl ParRed.rfl
-  | .lam .. => .lam ParRed.rfl ParRed.rfl
-  | .forallE .. => .forallE ParRed.rfl ParRed.rfl
-
-theorem ParRed.weakN (W : Ctx.LiftN n k Γ Γ') (H : ParRed TY Γ e1 e2) :
-    ParRed TY Γ' (e1.liftN n k) (e2.liftN n k) := by
-  induction H generalizing k Γ' with
-  | bvar | sort | const => exact .rfl
-  | app _ _ ih1 ih2 => exact .app (ih1 W) (ih2 W)
-  | lam _ _ ih1 ih2 => exact .lam (ih1 W) (ih2 W.succ)
-  | forallE _ _ ih1 ih2 => exact .forallE (ih1 W) (ih2 W.succ)
-  | beta _ _ ih1 ih2 =>
-    simp [liftN, liftN_inst_hi]
-    exact .beta (ih1 W.succ) (ih2 W)
-  | extra h1 h2 h3 _ ih =>
-    rw [Pattern.RHS.liftN_apply]
-    refine .extra h1 (Pattern.matches_liftN.2 ⟨_, h2, funext_iff.1 rfl⟩)
-      (h3.weakN W) (fun a => ih _ W)
-
-variable! (H₀ : ParRed TY Γ₀ a1 a2) (H₀' : TY.HasType Γ₀ a1 A₀) in
-theorem ParRed.instN (W : Ctx.InstN Γ₀ a1 A₀ k Γ₁ Γ)
-    (H : ParRed TY Γ₁ e1 e2) : ParRed TY Γ (e1.inst a1 k) (e2.inst a2 k) := by
-  induction H generalizing Γ k with
-  | @bvar _ i =>
-    dsimp [inst]
-    induction W generalizing i with
-    | zero =>
-      cases i with simp
-      | zero => exact H₀
-      | succ h => exact .rfl
-    | succ _ ih =>
-      cases i with simp
-      | zero => exact .rfl
-      | succ h => exact ih.weakN .one
-  | sort | const => exact .rfl
-  | app _ _ ih1 ih2 => exact .app (ih1 W) (ih2 W)
-  | lam _ _ ih1 ih2 => exact .lam (ih1 W) (ih2 W.succ)
-  | forallE _ _ ih1 ih2 => exact .forallE (ih1 W) (ih2 W.succ)
-  | beta _ _ ih1 ih2 =>
-    simp [inst, inst0_inst_hi]
-    exact .beta (ih1 W.succ) (ih2 W)
-  | extra h1 h2 h3 _ ih =>
-    rw [Pattern.RHS.instN_apply]
-    exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀') (fun a => ih _ W)
-
-theorem ParRed.defeq (H : ParRed TY Γ e e') (he : TY.HasType Γ e A) : TY.IsDefEqU Γ e e' := by
-  induction H generalizing A with
-  | bvar | sort | const => exact TY.refl he
-  | app _ _ ih1 ih2 =>
-    have ⟨_, _, h1, h2⟩ := TY.app_inv he
-    exact TY.appDF h1 (ih1 h1) h2 (ih2 h2)
-  | lam _ _ ih1 ih2 =>
-    have ⟨_, _, h1, h2⟩ := TY.lam_inv he
-    exact TY.lamDF h1 (ih1 h1) (ih2 h2)
-  | forallE _ _ ih1 ih2 =>
-    have ⟨_, _, h1, h2⟩ := TY.forallE_inv he
-    exact TY.forallEDF h1 (ih1 h1) h2 (ih2 h2)
-  | beta _ _ ih1 ih2 =>
-    have ⟨_, _, hf, ha⟩ := TY.app_inv he
-    have ⟨_, _, hA, hb⟩ := TY.lam_inv hf
-    have hf' := TY.lam hA hb
-    replace ha := TY.defeq_r (TY.forallE_defInv (TY.uniq hf hf')).1 ha
-    exact TY.trans (TY.appDF hf' (TY.lamDF hA (TY.refl hA) (ih1 hb)) ha (ih2 ha))
-      (TY.beta (TY.defeq_l (ih1 hb) hb) (TY.defeq_l (ih2 ha) ha))
-  | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih =>
-    exact TY.trans (TY.pat_wf h1 h2 he h3) <|
-     .apply_pat ih (TY.defeq_l (TY.pat_wf h1 h2 he h3) he)
-
-theorem ParRed.hasType (H : ParRed TY Γ e e') (he : TY.HasType Γ e A) : TY.HasType Γ e' A :=
-  TY.defeq_l (H.defeq he) he
-
-theorem ParRed.defeqDFC (W : IsDefEqCtx TY.IsDefEqU Γ₀ Γ₁ Γ₂)
-    (h : TY.HasType Γ₁ e1 A) (H : ParRed TY Γ₁ e1 e2) : ParRed TY Γ₂ e1 e2 := by
-  induction H generalizing Γ₂ A with
-  | bvar => exact .bvar
-  | sort => exact .sort
-  | const => exact .const
-  | app _ _ ih1 ih2 =>
-    have ⟨_, _, hf, ha⟩ := TY.app_inv h
-    exact .app (ih1 W hf) (ih2 W ha)
-  | lam _ _ ih1 ih2 =>
-    have ⟨_, _, hA, he⟩ := TY.lam_inv h
-    exact .lam (ih1 W hA) (ih2 (W.succ (TY.refl hA)) he)
-  | forallE _ _ ih1 ih2 =>
-    have ⟨_, _, hA, hB⟩ := TY.forallE_inv h
-    exact .forallE (ih1 W hA) (ih2 (W.succ (TY.refl hA)) hB)
-  | beta _ _ ih1 ih2 =>
-    have ⟨_, _, hf, ha⟩ := TY.app_inv h
-    have ⟨_, _, hA, hb⟩ := TY.lam_inv hf
-    exact .beta (ih1 (W.succ (TY.refl hA)) hb) (ih2 W ha)
-  | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih =>
-    exact .extra h1 h2 (h3.map fun a b h => TY.isDefEqU_DFC W h) fun a =>
-      let ⟨_, h⟩ := h2.hasType h a; ih a W h
-
-theorem ParRed.apply_pat {p : Pattern} (r : p.RHS) {m1 m2 m3}
-    (H : ∀ a, ParRed TY Γ (m2 a) (m3 a)) : ParRed TY Γ (r.apply m1 m2) (r.apply m1 m3) := by
-  match r with
-  | .fixed .. => exact .rfl
-  | .app f a => exact .app (apply_pat f H) (apply_pat a H)
-  | .var f => exact H _
-
-theorem Pattern.RHS.apply_liftN {p : Pattern} (r : p.RHS) {m1 m2} :
-    (r.apply m1 m2).liftN k n = r.apply m1 (fun a => (m2 a).liftN k n) := by
-  induction r with simp! [*]
-  | fixed _ h => exact instL_liftN.symm.trans ((h.liftN_eq (Nat.zero_le _)).symm ▸ rfl)
-
--- theorem IsDefEqU.applyL {p : Pattern} (r : p.RHS) {m1 m1' m2}
---     (H : ∀ a, List.Forall₂ (· ≈ ·) (m1 a) (m1' a))
---     (H2 : TY.HasType Γ (r.apply m1 m2) A) :
---     TY.IsDefEqU Γ (r.apply m1 m2) (r.apply m1' m2) := by
---   match r with
---   | .fixed .. =>
---     dsimp [Pattern.RHS.apply]
---     exact TY.hasType_instL _ _
---   | .app f a => exact .app (apply_pat f H) (apply_pat a H)
---   | .var f => exact H _
-
-theorem ParRed.weakN_inv (W : Ctx.LiftN n k Γ Γ')
-    (H : ParRed TY Γ' (e1.liftN n k) e2') :
-    ∃ e2, ParRed TY Γ e1 e2 ∧ e2' = e2.liftN n k := by
-  generalize eq : e1.liftN n k = e1' at H
-  induction H generalizing e1 Γ k with
-  | bvar => cases e1 <;> cases eq; exact ⟨_, .bvar, rfl⟩
-  | sort => cases e1 <;> cases eq; exact ⟨_, .sort, rfl⟩
-  | const => cases e1 <;> cases eq; exact ⟨_, .const, rfl⟩
-  | app h1 h2 ih1 ih2 =>
-    cases e1 <;> cases eq
-    obtain ⟨_, a1, rfl⟩ := ih1 W rfl
-    obtain ⟨_, b1, rfl⟩ := ih2 W rfl
-    exact ⟨_, .app a1 b1, rfl⟩
-  | lam h1 h2 ih1 ih2 =>
-    cases e1 <;> cases eq
-    obtain ⟨_, a1, rfl⟩ := ih1 W rfl
-    obtain ⟨_, b1, rfl⟩ := ih2 W.succ rfl
-    exact ⟨_, .lam a1 b1, rfl⟩
-  | forallE h1 h2 ih1 ih2 =>
-    cases e1 <;> cases eq
-    obtain ⟨_, a1, rfl⟩ := ih1 W rfl
-    obtain ⟨_, b1, rfl⟩ := ih2 W.succ rfl
-    exact ⟨_, .forallE a1 b1, rfl⟩
-  | beta h1 h2 ih1 ih2 =>
-    cases e1 <;> injection eq
-    rename_i f a eq eq2; cases eq2
-    cases f <;> cases eq
-    obtain ⟨_, a1, rfl⟩ := ih1 W.succ rfl
-    obtain ⟨_, b1, rfl⟩ := ih2 W rfl
-    exact ⟨_, .beta a1 b1, (liftN_inst_hi ..).symm⟩
-  | @extra p r e m1 m2 Γ' m2' h1 h2 h3 h4 ih =>
-    suffices ∃ m3 m3' : _ → _, p.Matches e1 m1 m3 ∧
-        (∀ a, ParRed TY Γ (m3 a) (m3' a)) ∧
-        (∀ a, m2 a = (m3 a).liftN n k) ∧
-        (∀ a, m2' a = (m3' a).liftN n k) by
-      let ⟨m3, m3', a1, a2, a3, a4⟩ := this
-      refine ⟨_, .extra h1 a1 (h3.map fun _ _ h => ?_) a2,
-        .trans (by congr; funext; apply a4) r.1.apply_liftN.symm⟩
-      rw [(funext a3 : m2 = _), ← Pattern.RHS.apply_liftN, ← Pattern.RHS.apply_liftN] at h
-      exact (TY.isDefEqU_weakN_iff W).1 h
-    clear h1 h3 r
-    induction h2 generalizing e1 with
-    | const => cases e1 <;> cases eq; exact ⟨_, nofun, .const, nofun, nofun, nofun⟩
-    | var h1 ih1 =>
-      cases e1 <;> cases eq
-      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| some ·) (ih <| some ·) rfl
-      have ⟨_, b2, b4⟩ := ih none W rfl
-      exact ⟨_, Option.rec _ _, .var a1, Option.rec b2 a2, Option.rec rfl a3, Option.rec b4 a4⟩
-    | app h1 h2 ih1 ih2 =>
-      cases e1 <;> cases eq
-      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| .inl ·) (ih <| .inl ·) rfl
-      have ⟨_, _, b1, b2, b3, b4⟩ := ih2 (h4 <| .inr ·) (ih <| .inr ·) rfl
-      exact ⟨_, Sum.rec _ _, .app a1 b1, Sum.rec a2 b2, Sum.rec a3 b3, Sum.rec a4 b4⟩
-
-theorem CParRed.toParRed (H : CParRed TY Γ e e') : ParRed TY Γ e e' := by
-  induction H with
-  | bvar => exact .bvar
-  | sort => exact .sort
-  | const => exact .const
-  | app _ _ _ ih1 ih2 => exact .app ih1 ih2
-  | lam _ _ ih1 ih2 => exact .lam ih1 ih2
-  | forallE _ _ ih1 ih2 => exact .forallE ih1 ih2
-  | beta _ _ ih1 ih2 => exact .beta ih1 ih2
-  | extra h1 h2 h3 _ ih3 => exact .extra h1 h2 h3 ih3
-
-theorem CParRed.exists (H : TY.HasType Γ e A) : ∃ e', CParRed TY Γ e e' := by
-  induction e using VExpr.brecOn generalizing Γ A with | _ e e_ih => ?_
-  revert e_ih; change let motive := ?_; ∀ _: e.below (motive := motive), _; intro motive e_ih
-  have neut {e} (H' : TY.HasType Γ e A) (e_ih : e.below (motive := motive)) :
-      NonNeutral TY Γ e → ∃ e', CParRed TY Γ e e' := by
-    rintro (⟨A, e, a, rfl⟩ | ⟨p, r, m1, m2, h1, hp2, hp3⟩)
-    · have ⟨_, _, hf, ha⟩ := TY.app_inv H'
-      have ⟨_, _, _, he⟩ := TY.lam_inv hf
-      have ⟨_, he⟩ := e_ih.1.2.2.1 he
-      have ⟨_, ha⟩ := e_ih.2.1 ha
-      exact ⟨_, .beta he ha⟩
-    · suffices ∃ m3 : p.Path → VExpr, ∀ a, CParRed TY Γ (m2 a) (m3 a) from
-        let ⟨_, h3⟩ := this; ⟨_, .extra h1 hp2 hp3 h3⟩
-      clear H r h1 hp3
-      induction p generalizing e m1 A with
-      | const => exact ⟨nofun, nofun⟩
-      | app f a ih1 ih2 =>
-        let .app hm1 hm2 := hp2
-        have ⟨_, _, H1, H2⟩ := TY.app_inv H'
-        have ⟨m2l, hl⟩ := ih1 H1 e_ih.1.2 _ _ hm1
-        have ⟨m2r, hr⟩ := ih2 H2 e_ih.2.2 _ _ hm2
-        exact ⟨Sum.elim m2l m2r, Sum.rec hl hr⟩
-      | var _ ih =>
-        let .var hm1 := hp2
-        have ⟨_, _, H1, H2⟩ := TY.app_inv H'
-        have ⟨m2l, hl⟩ := ih H1 e_ih.1.2 _ _ hm1
-        have ⟨e', hs⟩ := e_ih.2.1 H2
-        exact ⟨Option.rec e' m2l, Option.rec hs hl⟩
-  cases e with
-  | bvar i => exact ⟨_, .bvar⟩
-  | sort => exact ⟨_, .sort⟩
-  | const n ls => exact Classical.byCases (neut H e_ih) fun hn => ⟨_, .const hn⟩
-  | app ih1 ih2 =>
-    have ⟨_, _, hf, ha⟩ := TY.app_inv H
-    have ⟨_, h1⟩ := e_ih.1.1 hf
-    have ⟨_, h2⟩ := e_ih.2.1 ha
-    exact Classical.byCases (neut H e_ih) fun hn => ⟨_, .app hn h1 h2⟩
-  | lam ih1 ih2 =>
-    have ⟨_, _, hA, he⟩ := TY.lam_inv H
-    have ⟨_, h1⟩ := e_ih.1.1 hA
-    have ⟨_, h2⟩ := e_ih.2.1 he
-    exact ⟨_, .lam h1 h2⟩
-  | forallE ih1 ih2 =>
-    have ⟨_, _, hA, hB⟩ := TY.forallE_inv H
-    have ⟨_, h1⟩ := e_ih.1.1 hA
-    have ⟨_, h2⟩ := e_ih.2.1 hB
-    exact ⟨_, .forallE h1 h2⟩
-
-theorem ParRed.triangle (H1 : TY.HasType Γ e A) (H : ParRed TY Γ e e') (H2 : CParRed TY Γ e o) :
-    ∃ o', ParRed TY Γ e' o' ∧ NormalEq TY Γ o' o := by
-  induction e using VExpr.brecOn generalizing Γ A e' o with | _ e e_ih => ?_
-  revert e_ih; change let motive := ?_; ∀ _: e.below (motive := motive), _; intro motive e_ih
-  induction H2 generalizing A e' with
-  | bvar =>
-    cases H with
-    | bvar => exact ⟨_, .rfl, .refl H1⟩
-    | extra h1 h2 => cases h2
-  | sort =>
-    cases H with
-    | sort => exact ⟨_, .rfl, .refl H1⟩
-    | extra h1 h2 => cases h2
-  | const hn =>
-    cases H with
-    | const => exact ⟨_, .rfl, .refl H1⟩
-    | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩)
-  | app hn _ _ ih1 ih2 =>
-    have ⟨_, _, l1, l2⟩ := TY.app_inv H1
-    cases H with
-    | app r1 r2 =>
-      let ⟨_, p1, n1⟩ := ih1 l1 r1 e_ih.1.2; let ⟨_, p2, n2⟩ := ih2 l2 r2 e_ih.2.2
-      have o1 := p1.hasType (r1.hasType l1); have o2 := p2.hasType (r2.hasType l2)
-      exact ⟨_, .app p1 p2, .appDF o1 (TY.defeq_l n1.defeq o1) o2 (TY.defeq_l n2.defeq o2) n1 n2⟩
-    | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩)
-    | beta => cases hn (.inl ⟨_, _, _, rfl⟩)
-  | lam _ _ ih1 ih2 =>
-    have ⟨_, _, l1, l2⟩ := TY.lam_inv H1
-    cases H with
-    | lam r1 r2 =>
-      let ⟨_, p1, n1⟩ := ih1 l1 r1 e_ih.1.2; let ⟨_, p2, n2⟩ := ih2 l2 r2 e_ih.2.2
-      have := TY.symm <| TY.trans (r1.defeq l1) (p1.defeq (r1.hasType l1))
-      exact ⟨_, .lam p1 (p2.defeqDFC (.succ .zero (r1.defeq l1)) (r2.hasType l2)),
-        .lamDF l1 this (TY.trans (TY.symm n1.defeq) this) n2⟩
-    | extra h1 h2 => cases h2
-  | forallE _ _ ih1 ih2 =>
-    have ⟨_, _, l1, l2⟩ := TY.forallE_inv H1
-    cases H with
-    | forallE r1 r2 =>
-      let ⟨_, p1, n1⟩ := ih1 l1 r1 e_ih.1.2; let ⟨_, p2, n2⟩ := ih2 l2 r2 e_ih.2.2
-      exact ⟨_, .forallE p1 (p2.defeqDFC (.succ .zero (r1.defeq l1)) (r2.hasType l2)),
-        .forallEDF l1 (TY.symm <| TY.trans (r1.defeq l1) (p1.defeq (r1.hasType l1)))
-          n1 (p2.hasType (r2.hasType l2)) n2⟩
-    | extra h1 h2 => cases h2
-  | beta l1 l2 ih1 ih2 =>
-    have ⟨_, _, lf, la⟩ := TY.app_inv H1
-    have ⟨_, _, lA, le⟩ := TY.lam_inv lf
-    have hw := (TY.forallE_defInv (TY.uniq lf (TY.lam lA le))).1
-    have la' := TY.defeq_r hw la
-    obtain ⟨⟨-, ⟨-, e_ih1 : VExpr.below ..⟩, ⟨he, e_ih2 : VExpr.below ..⟩⟩,
-      ⟨ha, e_ih3 : VExpr.below ..⟩⟩ := e_ih
-    cases H with
-    | app rf ra =>
-      let ⟨_, p3, n3⟩ := ha la ra l2
-      cases rf with
-      | lam rA re =>
-        let ⟨_, p2, n2⟩ := he le re l1
-        refine ⟨_, .beta (p2.defeqDFC (.succ .zero (rA.defeq lA)) (re.hasType le)) p3, ?_⟩
-        refine .trans
-          (.instN_r (p3.hasType (ra.hasType la')) n3 .zero (p2.hasType (re.hasType le)))
-          (.instN (l2.toParRed.hasType la') .zero n2)
-      | extra h1 h2 => cases h2
-    | beta re ra =>
-      let ⟨_, p2, n2⟩ := he le re l1
-      let ⟨_, p3, n3⟩ := ha la ra l2
-      refine ⟨_, .instN p3 (ra.hasType la') .zero p2, ?_⟩
-      refine .trans
-        (.instN_r (p3.hasType (ra.hasType la')) n3 .zero (p2.hasType (re.hasType le)))
-        (.instN (l2.toParRed.hasType la') .zero n2)
-    | extra h1 h2 => cases h2 with | app h | var h => cases h
-  | @extra p r e m1 m2 Γ m2' l1 l2 l3 l4 ih =>
-    have :
-      (∃ m3 m3' : p.Path → VExpr, p.Matches e' m1 m3 ∧
-        (∀ a, ParRed TY Γ (m2 a) (m3 a)) ∧
-        (∀ a, ParRed TY Γ (m3 a) (m3' a)) ∧
-        (∀ a, NormalEq TY Γ (m3' a) (m2' a))) ∨
-      (∃ p₁ e₁' e₁ m1₁ m2₁, Subpattern p₁ p ∧ (p₁ = p → e₁ = e ∧ e₁' = e' ∧ m1₁ ≍ m1 ∧ m2₁ ≍ m2) ∧
-        p₁.Matches e₁ m1₁ m2₁ ∧ ∃ p' r m1 m2 m2',
-        TY.Pat p' r ∧ p'.Matches e₁ m1 m2 ∧ r.2.OK (TY.IsDefEqU Γ) m1 m2 ∧
-        (∀ a, ParRed TY Γ (m2 a) (m2' a)) ∧ e₁' = r.1.apply m1 m2') := by
-      clear l1 l3 l4 r
-      induction H generalizing p m1 A with
-      | const =>
-        cases id l2; exact .inl ⟨_, _, l2, nofun, fun _ => .rfl, nofun⟩
-      | @app Γ f f' a a' hf ha ih1 ih2 =>
-        have ⟨_, _, Hf, Ha⟩ := TY.app_inv H1
-        cases l2 with
-        | var lf =>
-          match ih1 lf (ih <| some ·) Hf e_ih.1.2 with
-          | .inr ⟨_, _, _, _, _, h1, h2, h3⟩ =>
-            refine .inr ⟨_, _, _, _, _, h1.varL, ?_, h3⟩
-            rintro rfl; cases h1.antisymm (.varL .refl)
-          | .inl ⟨_, _, f1, f2, f3, f4⟩ =>
-            have ⟨_, a3, a4⟩ := ih none Ha ha e_ih.2.2
-            exact .inl ⟨_, (·.elim _ _), .var f1,
-              (·.casesOn ha f2), (·.casesOn a3 f3), (·.casesOn a4 f4)⟩
-        | app lf la =>
-          match ih1 lf (ih <| .inl ·) Hf e_ih.1.2 with
-          | .inr ⟨_, _, _, _, _, h1, h2, h3⟩ =>
-            refine .inr ⟨_, _, _, _, _, h1.appL, ?_, h3⟩
-            rintro rfl; cases h1.antisymm (.appL .refl)
-          | .inl ⟨_, _, f1, f2, f3, f4⟩ =>
-            match ih2 la (ih <| .inr ·) Ha e_ih.2.2 with
-            | .inr ⟨_, _, _, _, _, h1, h2, h3⟩ =>
-              refine .inr ⟨_, _, _, _, _, h1.appR, ?_, h3⟩
-              rintro rfl; cases h1.antisymm (.appR .refl)
-            | .inl ⟨_, _, a1, a2, a3, a4⟩ =>
-              exact .inl ⟨_, Sum.elim _ _, .app f1 a1,
-                (·.casesOn f2 a2), (·.casesOn f3 a3), (·.casesOn f4 a4)⟩
-      | beta _ _ => cases l2 with | var h | app h => cases h
-      | @extra _ _ _ _ _ _ _ r1 r2 r3 r4 =>
-        exact .inr ⟨_, _, _, _, _, .refl, fun _ => ⟨rfl, rfl, .rfl, .rfl⟩,
-          l2, _, _, _, _, _, r1, r2, r3, r4, rfl⟩
-      | _ => cases l2
-    match this with
-    | .inl ⟨m3, m3', h1, h2, h3, h4⟩ =>
-      refine
-        have h := .extra l1 h1 (l3.map fun _ _ h => ?_) h3
-        ⟨_, h, .apply_pat (fun a _ _ => h4 a) (h.hasType (H.hasType H1))⟩
-      have ⟨_, h1⟩ := TY.has_type h
-      refine TY.trans (TY.symm (.apply_pat (fun _ _ => (h2 _).defeq) h1))
-        (TY.trans h (.apply_pat (fun _ _ => (h2 _).defeq) (TY.defeq_l h h1)))
-    | .inr ⟨_, _, _, _, _, h1, h2, l2', _, _, _, _, m3, r1, r2, r3, r4, e⟩ =>
-      obtain ⟨_, -, -, hr, -⟩ := Pattern.matches_inter.1 ⟨⟨_, _, r2⟩, ⟨_, _, l2'⟩⟩
-      obtain ⟨rfl, rfl, ⟨⟩⟩ := TY.pat_uniq l1 r1 h1 hr
-      obtain ⟨rfl, rfl, ⟨⟩, ⟨⟩⟩ := h2 rfl; subst e
-      obtain ⟨rfl, rfl⟩ := l2'.uniq r2
-      suffices ∃ m3' : p.Path → VExpr,
-          (∀ a, ParRed TY Γ (m3 a) (m3' a)) ∧
-          (∀ a, NormalEq TY Γ (m3' a) (m2' a)) by
-        let ⟨m3', h3, h4⟩ := this
-        refine ⟨_, ?h3, .apply_pat (fun a _ _ => h4 a) ((?h3).hasType (H.hasType H1))⟩
-        exact .apply_pat _ h3
-      clear H r l1 l2 l3 l4 this h1 h2 r1 r2 r3 hr
-      induction l2' generalizing A with
-      | const => exact ⟨nofun, nofun, nofun⟩
-      | app _ _ ih1 ih2 =>
-        have ⟨_, _, Hf, Ha⟩ := TY.app_inv H1
-        obtain ⟨⟨hl, e_ih1 : VExpr.below ..⟩, ⟨hr, e_ih2 : VExpr.below ..⟩⟩ := id e_ih
-        have ⟨g1, l1, l2⟩ := ih1 (ih <| .inl ·) _ Hf e_ih1 (r4 <| .inl ·)
-        have ⟨g2, r1, r2⟩ := ih2 (ih <| .inr ·) _ Ha e_ih2 (r4 <| .inr ·)
-        exact ⟨Sum.elim g1 g2, (·.casesOn l1 r1), (·.casesOn l2 r2)⟩
-      | var _ ih1 =>
-        have ⟨_, _, Hf, Ha⟩ := TY.app_inv H1
-        obtain ⟨⟨hl, e_ih1 : VExpr.below ..⟩, ⟨hr, e_ih2 : VExpr.below ..⟩⟩ := id e_ih
-        have ⟨g1, l1, l2⟩ := ih1 (ih <| some ·) _ Hf e_ih1 (r4 <| some ·)
-        have ⟨g2, r1, r2⟩ := ih none Ha (r4 none) e_ih2
-        exact ⟨(·.elim g2 g1), (·.casesOn r1 l1), (·.casesOn r2 l2)⟩
-
-theorem ParRed.church_rosser (H : TY.HasType Γ e A)
-    (H1 : ParRed TY Γ e e₁) (H2 : ParRed TY Γ e e₂) :
-      ∃ e₁' e₂', ParRed TY Γ e₁ e₁' ∧ ParRed TY Γ e₂ e₂' ∧ NormalEq TY Γ e₁' e₂' := by
-  let ⟨e', h'⟩ := CParRed.exists H
-  let ⟨_, l1, l2⟩ := H1.triangle H h'
-  let ⟨_, r1, r2⟩ := H2.triangle H h'
-  exact ⟨_, _, l1, r1, l2.trans r2.symm⟩
-
-def ParRedS (TY : Typing) (Γ : List VExpr) : VExpr → VExpr → Prop := ReflTransGen (ParRed TY Γ)
-
-theorem ParRedS.hasType (H : ParRedS TY Γ e e') : TY.HasType Γ e A → TY.HasType Γ e' A := by
-  induction H with
-  | rfl => exact id
-  | tail h1 h2 ih => exact h2.hasType ∘ ih
-
-theorem ParRedS.defeq (H : ParRedS TY Γ e e') (h : TY.HasType Γ e A) : TY.IsDefEqU Γ e e' := by
-  induction H with
-  | rfl => exact TY.refl h
-  | tail h1 h2 ih => refine TY.trans ih (h2.defeq (hasType h1 h))
-
-theorem ParRedS.defeqDFC (W : IsDefEqCtx TY.IsDefEqU Γ₀ Γ₁ Γ₂)
-    (h : TY.HasType Γ₁ e1 A) (H : ParRedS TY Γ₁ e1 e2) : ParRedS TY Γ₂ e1 e2 := by
-  induction H with
-  | rfl => exact .rfl
-  | tail h1 h2 ih => refine .tail ih (h2.defeqDFC W (hasType h1 h))
-
-theorem ParRedS.app (hf : ParRedS TY Γ f f') (ha : ParRedS TY Γ a a') :
-    ParRedS TY Γ (f.app a) (f'.app a') := by
-  have : ParRedS TY Γ (f.app a) (f.app a') := by
-    induction ha with
-    | rfl => exact .rfl
-    | tail a1 a2 iha => exact .tail iha (.app .rfl a2)
-  refine this.trans ?_; clear this ha
-  induction hf with
-  | rfl =>  exact .rfl
-  | tail f1 f2 ihf => exact .tail ihf (.app f2 .rfl)
-
-theorem ParRedS.lam (hf : ParRedS TY Γ A A') (ha : ParRedS TY (A::Γ) body body') :
-    ParRedS TY Γ (A.lam body) (A'.lam body') := by
-  have : ParRedS TY Γ (A.lam body) (A.lam body') := by
-    induction ha with
-    | rfl => exact .rfl
-    | tail a1 a2 iha => exact .tail iha (.lam .rfl a2)
-  refine this.trans ?_; clear this ha
-  induction hf with
-  | rfl =>  exact .rfl
-  | tail f1 f2 ihf => exact .tail ihf (.lam f2 .rfl)
-
-theorem ParRedS.forallE (hf : ParRedS TY Γ A A') (ha : ParRedS TY (A::Γ) body body') :
-    ParRedS TY Γ (A.forallE body) (A'.forallE body') := by
-  have : ParRedS TY Γ (A.forallE body) (A.forallE body') := by
-    induction ha with
-    | rfl => exact .rfl
-    | tail a1 a2 iha => exact .tail iha (.forallE .rfl a2)
-  refine this.trans ?_; clear this ha
-  induction hf with
-  | rfl =>  exact .rfl
-  | tail f1 f2 ihf => exact .tail ihf (.forallE f2 .rfl)
-
-theorem ParRedS.inst (Ha : TY.HasType Γ a A)
-    (hf : ParRedS TY (A :: Γ) f f') (ha : ParRedS TY Γ a a') :
-    ParRedS TY Γ (f.inst a) (f'.inst a') := by
-  have : ParRedS TY Γ (f.inst a) (f.inst a') := by
-    induction ha with
-    | rfl => exact .rfl
-    | tail a1 a2 iha => exact .tail iha (.instN a2 (ParRedS.hasType a1 Ha) .zero .rfl)
-  replace Ha := ha.hasType Ha
-  refine this.trans ?_; clear this ha
-  induction hf with
-  | rfl =>  exact .rfl
-  | tail _ h ihf => exact .tail ihf (.instN .rfl Ha .zero h)
-
-theorem ParRedS.weakN (W : Ctx.LiftN n k Γ Γ') (H : ParRedS TY Γ e e') :
-    ParRedS TY Γ' (e.liftN n k) (e'.liftN n k) := by
-  induction H with
-  | rfl =>  exact .rfl
-  | tail _ h ih => exact .tail ih (.weakN W h)
-
-inductive ParRedExt : Type where
-  | base : ParRedExt
-  | lift : ParRedExt → ParRedExt
-  | app : ParRedExt → ParRedExt
-
-def ParRedExt.depth : ParRedExt → Nat
-  | .base => 0
-  | .lift l
-  | .app l => l.depth + 1
-
-def ParRedExt.apply : ParRedExt → VExpr → VExpr
-  | .base, e => e
-  | .lift l, e => (l.apply e).lift
-  | .app l, e => (l.apply e).lift.app (.bvar 0)
-
-def ParRedExt.meas : ParRedExt → Nat
-  | .base => 0
-  | .lift l => l.meas + 1
-  | .app l => l.meas + 2
-
-def IsApp := fun | VExpr.app .. => True | _ => False
-
-theorem ParRedExt.isApp {l : ParRedExt} (H : l.apply (.app f a) = e') : IsApp e' := by
-  induction l generalizing e' with simp [apply] at H
-  | lift l ih =>
-    specialize ih rfl; unfold IsApp at ih; split at ih <;> cases ih <;>
-    · rename_i h1; cases h1 ▸ H; trivial
-  | _ => subst H; trivial
-
-theorem hasType_app_bvar0
-    (H : TY.HasType (A :: Γ) (e.lift.app (bvar 0)) B) :
-    ∃ B', TY.HasType Γ e (.forallE A B') := by
-  have ⟨_, _, c1, c2⟩ := TY.app_inv H
-  replace c1 :=
-    have ⟨_, d1⟩ := TY.is_type c1
-    have ⟨_, _, d2, d3⟩ := TY.forallE_inv d1
-    have := TY.forallEDF d2 (TY.uniq c2 (TY.bvar .zero)) d3 (TY.refl d3)
-    TY.defeq_r this c1
-  have : A.lift.lam (e.lift.lift.app (bvar 0)) =
-      (A.lam (e.lift.app (bvar 0))).lift := by
-    simp [VExpr.liftN, liftN'_liftN_lo, liftN_liftN]
-  have := (TY.isDefEqU_weakN_iff .one).1 (this ▸ TY.eta c1)
-  have ⟨_, f1⟩ := TY.has_type this
-  have ⟨_, _, f2, f3⟩ := TY.lam_inv f1
-  exact ⟨_, TY.defeq_l this (TY.lam f2 f3)⟩
-
-theorem ParRedExt.parRed_beta :
-  NormalEq TY Γ f (lam A e') → ∀ {a B}, TY.HasType Γ (f.app a) B →
-    ∃ e, ParRedS TY Γ (f.app a) e ∧ NormalEq TY Γ e (e'.inst a) := by
-  refine (?_ : _ ∧ ∀ (l : ParRedExt), l.depth ≤ Γ.length →
-    NormalEq TY Γ f (l.apply ((lam A e').lift.app (bvar 0))) →
-    ∃ e, ParRedS TY Γ f e ∧ NormalEq TY Γ e (l.apply e')).1
-  induction f using VExpr.brecOn generalizing Γ A e' with | _ f f_ih => ?_
-  revert f_ih; change let motive := ?_; ∀ _: f.below (motive := motive), _; intro motive f_ih
-  refine ⟨fun h1 a B h2 => ?_, fun l W h1 => ?_⟩
-  · cases h1 with
-    | @refl _ _ B H =>
-      clear f_ih motive
-      exact have h := .beta .rfl .rfl; ⟨_, .tail .rfl h, .refl (h.hasType h2)⟩
-    | lamDF a1 a2 a3 a4 =>
-      have ⟨_, _, H1, H2⟩ := TY.app_inv h2
-      have ⟨_, _, H3, H4⟩ := TY.lam_inv H1
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.lam H3 H4) H1)
-      exact ⟨_, .tail .rfl <| .beta .rfl .rfl,
-        .instN (TY.defeq_r (TY.trans (TY.symm u1) a2) H2) .zero a4⟩
-    | @etaL _ _ A' _ _ a1 a2 =>
-      have ⟨_, _, c1, c2⟩ := TY.lam_inv a1
-      have ⟨_, d1, d2⟩ := f_ih.2.1.2 .base (Nat.zero_le _) a2
-      have ⟨_, _, c3, c4⟩ := TY.app_inv h2
-      have ⟨_, _, c1, c2⟩ := TY.lam_inv c3
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.lam c1 c2) c3)
-      exact ⟨_, .tail (ParRedS.app (.lam .rfl d1) .rfl) <| .beta .rfl .rfl,
-        .instN (TY.defeq_r (TY.symm u1) c4) .zero d2⟩
-    | etaR a1 a2 =>
-      have ⟨_, _, H1, H2⟩ := TY.app_inv h2
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq H1 a1)
-      have := a2.instN (TY.defeq_r u1 H2) .zero
-      simp [inst, inst_lift] at this
-      exact ⟨_, .rfl, this⟩
-    | proofIrrel a1 a2 a3 =>
-      have ⟨_, _, H1, H2⟩ := TY.app_inv h2
-      have hf := TY.uniq a2 H1; have := TY.defeq_l hf a1
-      have ⟨_, _, b1, b2⟩ := TY.forallE_inv this
-      have := TY.univ_defInv (TY.uniq (TY.forallE b1 b2) this)
-      have b3 := let ⟨_, h⟩ := TY.is_type b2; TY.sort_inv h
-      have b2 := TY.defeq_r (TY.sortDF b3 (by trivial) (VLevel.imax_eq_zero.1 this)) b2
-      have ⟨_, _, c1, c2⟩ := TY.lam_inv a3
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.trans (TY.uniq (TY.lam c1 c2) a3) hf)
-      exact ⟨_, .rfl, .proofIrrel (TY.isDefEq_instN .zero b2 H2) (TY.app H1 H2)
-        (TY.isDefEq_instN .zero (TY.defeq_r u2 c2) (TY.defeq_r (TY.symm u1) H2))⟩
-  generalize eq : l.apply .. = s at h1
-  cases h1 with
-  | @refl _ _ B H =>
-    subst eq; clear f_ih motive
-    generalize ls : l.meas = n
-    induction n using Nat.strongRecOn generalizing l Γ B with | _ _ ih; subst ls
-    cases l with
-    | base =>
-      refine have h := .beta .rfl .rfl; ⟨_, .tail .rfl h, ?_⟩
-      simp [instN_bvar0] at h ⊢; exact .refl (h.hasType H)
-    | lift l =>
-      let A::Γ := Γ
-      have ⟨_, a1⟩ := TY.isDefEq_weakN_inv .one H
-      have ⟨_, a2, a3⟩ := ih _ (by simp [meas]) l (by simpa [depth] using W) a1 rfl
-      exact ⟨_, .weakN .one a2, .weakN .one a3⟩
-    | app l =>
-      let A::Γ := Γ
-      have ⟨_, _, H1, H2⟩ := TY.app_inv H
-      have ⟨_, a1, a2⟩ := ih _ (by simp [meas]) (lift l) W H1 rfl
-      have := a1.hasType H1
-      refine ⟨_, .app a1 .rfl, .appDF this (TY.defeq_l a2.defeq this) H2 H2 a2 (.refl H2)⟩
-  | @appDF _ _ A' B' f' _ a' a1 a2 a3 a4 a5 a6 =>
-    obtain ⟨n, rfl, ⟨rfl, h⟩ | ⟨l', W', rfl, h⟩⟩ : ∃ n, a' = bvar n ∧
-        (f' = (A.lam e').liftN (n+1) ∧ l.apply e' = liftN n e' ∨
-        ∃ l', l'.depth ≤ l.depth ∧
-          f' = apply l' ((A.lam e').lift.app (bvar 0)) ∧
-          l.apply e' = (l'.apply e').app (bvar n)) := by
-      clear W a2 a4 a5 a6
-      induction l generalizing f' a' with
-      | base => cases eq; exact ⟨_, rfl, .inl ⟨rfl, by simp [apply]⟩⟩
-      | lift l ih =>
-        simp [apply] at eq
-        generalize eq' : apply .. = s at eq; cases s <;> cases eq
-        obtain ⟨n, rfl, ⟨rfl, h⟩ | ⟨l', W', rfl, h⟩⟩ := ih eq'
-        · refine ⟨_, rfl, .inl ⟨by simp [liftN_liftN], ?_⟩⟩
-          have := congrArg VExpr.lift h
-          simpa [lift_inst_hi, liftN'_liftN']
-        · exact ⟨_, rfl, .inr ⟨lift _, Nat.succ_le_succ W', rfl, congrArg VExpr.lift h⟩⟩
-      | app l ih => cases eq; exact ⟨_, rfl, .inr ⟨lift _, Nat.le_refl _, rfl, rfl⟩⟩
-    · have ⟨_, _, c1, c2⟩ := TY.lam_inv (TY.defeq_l a5.defeq a1)
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.defeq_l a5.defeq a1) (TY.lam c1 c2))
-      have ⟨_, b1, b2⟩ := f_ih.1.1.1 a5 (TY.app a1 a3)
-      replace b2 := b2.trans (.instN_r (TY.defeq_r u1 a3) a6 .zero c2)
-      have := congrArg (liftN n) (instN_bvar0 e' 0)
-      simp [liftN_inst_hi, liftN'_liftN', liftN] at this
-      rw [Nat.add_comm, this, ← h] at b2
-      exact ⟨_, b1, b2⟩
-    · have ⟨_, b1, b2⟩ := f_ih.1.1.2 l' (Nat.le_trans W' W) a5
-      rw [h]; have := b1.hasType a1
-      exact ⟨_, .app b1 .rfl, .appDF this (TY.defeq_l b2.defeq this) a3 a4 b2 a6⟩
-  | @etaL _ _ A' _ _ a1 a2 =>
-    subst eq
-    have ⟨_, b1, b2⟩ := f_ih.2.1.2 (app l) (by exact Nat.succ_le_succ W) a2
-    have ⟨_, c1⟩ := TY.has_type b2.symm.defeq
-    let ⟨_, b3⟩ := hasType_app_bvar0 c1
-    exact ⟨_, .lam .rfl b1, .etaL b3 b2⟩
-  | @proofIrrel _ p _ _ a1 a2 a3 =>
-    subst eq; refine ⟨_, .rfl, .proofIrrel a1 a2 ?_⟩
-    clear a2; induction l generalizing Γ p with
-    | base =>
-      have ⟨_, _, b1, b2⟩ := TY.app_inv a3
-      have ⟨_, _, b3, b4⟩ := TY.lam_inv b1
-      have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.lam b3 b4) b1)
-      have := TY.beta b4 (TY.defeq_r (TY.symm u1) b2)
-      simp [instN_bvar0] at this
-      exact TY.defeq_l this a3
-    | lift l ih =>
-      let A::Γ := Γ
-      have ⟨_, b1⟩ := TY.isDefEq_weakN_inv .one a3
-      have u1 := TY.uniq a3 ((TY.isDefEq_weakN_iff .one).2 b1)
-      have := (TY.isDefEq_weakN_iff (A := sort _) .one).1 (TY.defeq_l u1 a1)
-      have := ih (Nat.le_of_succ_le_succ W) this b1
-      exact TY.defeq_r (TY.symm u1) ((TY.isDefEq_weakN_iff .one).2 this)
-    | app l ih =>
-      let A::Γ := Γ
-      let ⟨_, b1⟩ := hasType_app_bvar0 a3
-      have H := TY.uniq a3 (TY.app ((TY.isDefEq_weakN_iff .one).2 b1) (TY.bvar .zero))
-      simp [instN_bvar0] at H
-      have ⟨_, _, b2, b3⟩ := have ⟨_, b2⟩ := TY.is_type b1; TY.forallE_inv b2
-      have wf := let ⟨_, h⟩ := TY.is_type b2; TY.sort_inv h
-      have := TY.forallE b2 (TY.defeq_l H a1)
-      have := TY.defeq_r (TY.sortDF (by exact ⟨wf, ⟨⟩⟩) (by trivial) VLevel.imax_zero) this
-      have := ih (Nat.le_of_succ_le_succ W) this b1
-      have := TY.app ((TY.isDefEq_weakN_iff .one).2 this) (TY.bvar .zero)
-      simp [instN_bvar0] at this
-      exact TY.defeq_r (TY.symm H) this
-  | _ => cases l.isApp eq
-
-theorem NormalEq.parRed (H1 : NormalEq TY Γ e₁ e₂) (H2 : ParRed TY Γ e₂ e₂') :
-    ∃ e₁', ParRedS TY Γ e₁ e₁' ∧ NormalEq TY Γ e₁' e₂' := by
-  induction H1 generalizing e₂' with
-  | refl l1 => exact ⟨_, .tail .rfl H2, .refl (H2.hasType l1)⟩
-  | sortDF l1 l2 l3 =>
-    cases H2 with
-    | sort => exact ⟨_, .tail .rfl .sort, .sortDF l1 l2 l3⟩
-    | extra r1 r2 => cases r2
-  | constDF l1 l2 l3 l4 l5 =>
-    cases H2 with
-    | const => exact ⟨_, .tail .rfl .const, .constDF l1 l2 l3 l4 l5⟩
-    | extra r1 r2 r3 r4 =>
-      sorry
-  | @appDF Γ f A B f₂ a b l1 l2 l3 l4 l5 l6 ih1 ih2 =>
-    cases H2 with
-    | app r1 r2 =>
-      let ⟨_, a1, a2⟩ := ih1 r1
-      let ⟨_, b1, b2⟩ := ih2 r2
-      exact ⟨_, .app a1 b1,
-        .appDF (a1.hasType l1) (r1.hasType l2) (b1.hasType l3) (r2.hasType l4) a2 b2⟩
-    | @beta A _ e e' _ b' r1 r2 =>
-      let ⟨f', a1, a2⟩ := ih1 (.lam .rfl r1)
-      let ⟨a', b1, b2⟩ := ih2 r2
-      let ⟨_, _, d1, d2⟩ := TY.lam_inv l2
-      let ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.lam d1 d2) l2)
-      replace d2 := r1.hasType (TY.defeq_r u2 d2)
-      replace l3 := b1.hasType (TY.defeq_r (TY.symm u1) l3)
-      let ⟨_, h1, h2⟩ := ParRedExt.parRed_beta a2
-        (TY.app (TY.defeq_l a2.symm.defeq (TY.lam d1 d2)) l3)
-      exact ⟨_, .trans (a1.app b1) h1, h2.trans (.instN_r l3 b2 .zero d2)⟩
-    | extra r1 r2 r3 r4 =>
-      sorry
-  | lamDF l1 l2 l3 l4 ih1 =>
-    cases H2 with
-    | lam r1 r2 =>
-      have ⟨_, h1⟩ := TY.has_type l4.defeq
-      have h2 := TY.defeq_l l4.defeq h1
-      replace r2 := r2.defeqDFC (.succ .zero l3) <| TY.isDefEq_DFC (.succ .zero (TY.symm l3)) h2
-      let ⟨_, b1, b2⟩ := ih1 r2
-      exact ⟨_, .lam .rfl (b1.defeqDFC (.succ .zero (TY.symm l2)) h1),
-        .lamDF l1 l2 (TY.trans (TY.symm (r1.defeq (TY.defeq_l (TY.symm l3) l1))) l3) b2⟩
-    | extra _ r2 => cases r2
-  | forallEDF l1 l2 l3 l4 l5 ih1 ih2 =>
-    cases H2 with
-    | forallE r1 r2 =>
-      let ⟨_, a1, a2⟩ := ih1 r1
-      have h2 := TY.defeq_l l5.defeq l4
-      have W := TY.trans l3.symm.defeq l2
-      replace r2 := r2.defeqDFC (.succ .zero W) <| TY.isDefEq_DFC (.succ .zero (TY.symm W)) h2
-      let ⟨_, b1, b2⟩ := ih2 r2
-      have := r1.defeq (TY.defeq_l (TY.symm W) l1)
-      exact ⟨_, .forallE a1 (b1.defeqDFC (.succ .zero (TY.symm l2)) l4),
-        .forallEDF l1 (TY.trans a2.defeq <| TY.trans (TY.symm this) W) a2 (b1.hasType l4) b2⟩
-    | extra _ r2 => cases r2
-  | etaL l1 l2 ih1 =>
-    let ⟨_, a1, a2⟩ := ih1 (.app (.weakN .one H2) .bvar)
-    exact ⟨_, .lam .rfl a1, .etaL (H2.hasType l1) a2⟩
-  | @etaR Γ e A _ _ l1 l2 ih1 =>
-    cases H2 with
-    | lam r1 r2 =>
-      let ⟨t, a1, a2⟩ := ih1 r2
-      have ⟨_, c1⟩ := TY.is_type l1
-      have ⟨_, _, c1, c2⟩ := TY.forallE_inv c1
-      suffices
-          (∃ A', ParRedS TY Γ e (A'.lam t) ∧ TY.IsDefEqU Γ A' A) ∨
-          (∃ e', ParRedS TY Γ e e' ∧ t = .app (.lift e') (.bvar 0)) by
-        obtain ⟨_, h1, h2⟩ | ⟨_, h, rfl⟩ := this
-        · exact ⟨_, h1, .lamDF c1 h2 (TY.symm (r1.defeq c1)) a2⟩
-        · have := a2.etaR (h.hasType l1)
-          have ⟨_, a3⟩ := TY.has_type a2.symm.defeq
-          exact ⟨_, h, this.trans (.lamDF c1 (TY.refl c1) (TY.symm (r1.defeq c1)) (.refl a3))⟩
-      generalize eq : e.lift.app (.bvar 0) = e' at a1
-      clear l2 ih1 a2
-      induction a1 generalizing e with subst eq
-      | rfl => exact .inr ⟨_, .rfl, rfl⟩ | tail _ a1 ih
-      obtain ⟨_, h1, h2⟩ | ⟨e', h, rfl⟩ := ih l1 rfl
-      · have ⟨_, _, d1, d2⟩ := TY.lam_inv (h1.hasType l1)
-        exact .inl ⟨_, h1.tail <| .lam .rfl (a1.defeqDFC (.succ .zero (TY.symm h2))
-          (TY.isDefEq_DFC (.succ .zero h2) d2)), h2⟩
-      generalize eq : e'.lift = e1 at a1
-      cases a1 with
-      | app b1 b2 =>
-        cases b2 with | bvar => ?_ | extra _ h => cases h
-        cases eq; obtain ⟨_, b1', rfl⟩ := b1.weakN_inv .one
-        exact .inr ⟨_, .tail h b1', rfl⟩
-      | beta b1 b2 =>
-        cases b2 with | bvar => ?_ | extra _ h => cases h
-        cases e' <;> cases eq
-        obtain ⟨_, b1', rfl⟩ := b1.weakN_inv (.succ .one)
-        rw [instN_bvar0]
-        have l1' := h.hasType l1
-        have ⟨_, _, d1, d2⟩ := TY.lam_inv l1'
-        have ⟨u1, u2⟩ := TY.forallE_defInv (TY.uniq (TY.lam d1 d2) l1')
-        exact .inl ⟨_, .tail h <| .lam .rfl b1', u1⟩
-      | extra b1 b2 b3 b4 =>
-        cases b2 with | app _ h => cases h | var => cases TY.pat_not_var b1
-    | extra _ r2 => cases r2
-  | proofIrrel l1 l2 l3 => exact ⟨_, .rfl, .proofIrrel l1 l2 (H2.hasType l3)⟩
-
-theorem NormalEq.parRedS (H1 : NormalEq TY Γ e₁ e₂) (H2 : ParRedS TY Γ e₂ e₂') :
-    ∃ e₁', ParRedS TY Γ e₁ e₁' ∧ NormalEq TY Γ e₁' e₂' := by
-  induction H2 with
-  | rfl => exact ⟨_, .rfl, H1⟩
-  | tail h1 h2 ih =>
-    let ⟨_, a1, a2⟩ := ih
-    let ⟨_, b1, b2⟩ := a2.parRed h2
-    exact ⟨_, .trans a1 b1, b2⟩
-
-def Typing.CRDefEq (Γ : List VExpr) (e₁ e₂ : VExpr) : Prop :=
-  (∃ A, TY.HasType Γ e₁ A) ∧ (∃ A, TY.HasType Γ e₂ A) ∧
-  ∃ e₁' e₂', ParRedS TY Γ e₁ e₁' ∧ ParRedS TY Γ e₂ e₂' ∧ NormalEq TY Γ e₁' e₂'
-
-theorem ParRedS.church_rosser  (H : TY.HasType Γ e A)
-    (H1 : ParRedS TY Γ e e₁) (H2 : ParRedS TY Γ e e₂) : TY.CRDefEq Γ e₁ e₂ := by
-  refine ⟨⟨_, H1.hasType H⟩, ⟨_, H2.hasType H⟩, ?_⟩
-  induction H2 with
-  | rfl => exact ⟨_, _, .rfl, H1, .refl (H1.hasType H)⟩
-  | @tail b c h1 H2 ih =>
-    replace H := ParRedS.hasType h1 H
-    have ⟨_, A2, a1, a2, a3⟩ := ih
-    have ⟨_, _, b1, b2, b3⟩ :
-        ∃ e₁' e₂', ParRed TY Γ A2 e₁' ∧ ParRedS TY Γ c e₂' ∧ NormalEq TY Γ e₁' e₂' := by
-      clear a3; induction a2 with
-      | rfl => exact ⟨_, _, H2, .rfl, .refl (H2.hasType H)⟩
-      | tail h1 h2 ih =>
-        have ⟨_, _, a1, a2, a3⟩ := ih
-        have ⟨_, _, b1, b2, b3⟩ := a1.church_rosser (ParRedS.hasType h1 H) h2
-        have ⟨_, c1, c2⟩ := a3.symm.parRed b1
-        exact ⟨_, _, b2, .trans a2 c1, (c2.trans b3).symm⟩
-    have ⟨_, c1, c2⟩ := a3.parRed b1
-    exact ⟨_, _, .trans a1 c1, b2, c2.trans b3⟩
-
-theorem Typing.CRDefEq.normalEq (H : NormalEq TY Γ e₁ e₂) : TY.CRDefEq Γ e₁ e₂ :=
-  ⟨TY.has_type H.defeq, TY.has_type H.symm.defeq, _, _, .rfl, .rfl, H⟩
-
-theorem Typing.CRDefEq.refl (H : TY.HasType Γ e A) : TY.CRDefEq Γ e e :=
-  .normalEq (.refl H)
-
-theorem Typing.CRDefEq.defeq : TY.CRDefEq Γ e₁ e₂ → TY.IsDefEqU Γ e₁ e₂
-  | ⟨⟨_, h1⟩, ⟨_, h2⟩, _, _, h3, h4, h5⟩ =>
-    TY.trans (h3.defeq h1) <| TY.trans h5.defeq (TY.symm (h4.defeq h2))
-
-theorem Typing.CRDefEq.symm : TY.CRDefEq Γ e₁ e₂ → TY.CRDefEq Γ e₂ e₁
-  | ⟨h1, h2, _, _, h3, h4, h5⟩ => ⟨h2, h1, _, _, h4, h3, h5.symm⟩
-
-theorem Typing.CRDefEq.trans : TY.CRDefEq Γ e₁ e₂ → TY.CRDefEq Γ e₂ e₃ → TY.CRDefEq Γ e₁ e₃
-  | ⟨l1, ⟨_, l2⟩, _, _, l3, l4, l5⟩, ⟨_, r2, _, _, r3, r4, r5⟩ => by
-    let ⟨_, _, _, _, m1, m2, m3⟩ := l4.church_rosser l2 r3
-    let ⟨_, a1, a2⟩ := l5.parRedS m1
-    let ⟨_, b1, b2⟩ := r5.symm.parRedS m2
-    exact ⟨l1, r2, _, _, .trans l3 a1, .trans r4 b1, a2.trans <| m3.trans b2.symm⟩
-
-theorem VEnv.IsDefEq.toTyping (H : TY.env.IsDefEq TY.univs Γ e₁ e₂ A) :
-    TY.IsDefEqU Γ e₁ e₂ ∧ TY.HasType Γ e₁ A := by
-  induction H with
-  | bvar h => exact ⟨TY.refl (TY.bvar h), TY.bvar h⟩
-  | symm _ ih => exact ⟨TY.symm ih.1, TY.defeq_l ih.1 ih.2⟩
-  | trans _ _ ih1 ih2 => exact ⟨TY.trans ih1.1 ih2.1, ih1.2⟩
-  | sortDF h1 h2 h3 => exact ⟨TY.sortDF h1 h2 h3, TY.sort h1⟩
-  | constDF h1 h2 h3 h4 h5 => exact ⟨TY.constDF h1 h2 h3 h4 h5, TY.const h1 h2 h4⟩
-  | appDF h1 h2 ih1 ih2 => exact ⟨TY.appDF ih1.2 ih1.1 ih2.2 ih2.1, TY.app ih1.2 ih2.2⟩
-  | lamDF h1 h2 ih1 ih2 => exact ⟨TY.lamDF ih1.2 ih1.1 ih2.1, TY.lam ih1.2 ih2.2⟩
-  | forallEDF h1 h2 ih1 ih2 => exact ⟨TY.forallEDF ih1.2 ih1.1 ih2.2 ih2.1, TY.forallE ih1.2 ih2.2⟩
-  | defeqDF h1 h2 ih1 ih2 => exact ⟨ih2.1, TY.defeq_r ih1.1 ih2.2⟩
-  | beta h1 h2 ih1 ih2 =>
-    have h := TY.beta ih1.2 ih2.2
-    exact ⟨h, TY.defeq_l (TY.symm h) (TY.isDefEq_instN .zero ih1.2 ih2.2)⟩
-  | eta h1 ih1 => have h := TY.eta ih1.2; exact ⟨h, TY.defeq_l (TY.symm h) ih1.2⟩
-  | proofIrrel h1 h2 h3 ih1 ih2 ih3 => exact ⟨TY.proofIrrel ih1.2 ih2.2 ih3.2, ih2.2⟩
-  | extra h1 h2 h3 => exact ⟨TY.extraDF h1 h2 h3, TY.extra h1 h2 h3⟩
-
-theorem VEnv.IsDefEqU.church_rosser
-    (H : TY.env.IsDefEq TY.univs Γ e₁ e₂ A) : TY.CRDefEq Γ e₁ e₂ := by
-  have mk {Γ e₁ e₂ A e₁' e₂'} (H : TY.env.IsDefEq TY.univs Γ e₁ e₂ A)
-      (h1 : ParRedS TY Γ e₁ e₁') (h2 : ParRedS TY Γ e₂ e₂') (h3 : NormalEq TY Γ e₁' e₂') :
-      TY.CRDefEq Γ e₁ e₂ :=
-    ⟨⟨_, H.toTyping.2⟩, ⟨_, H.symm.toTyping.2⟩, _, _, h1, h2, h3⟩
-  induction H with
-  | bvar h => exact .refl (TY.bvar h)
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ih1.trans ih2
-  | sortDF h1 h2 h3 => exact .normalEq (.sortDF h1 h2 h3)
-  | constDF h1 h2 h3 h4 h5 => exact .normalEq (.constDF h1 h2 h3 h4 h5)
-  | appDF h1 h2 ih1 ih2 =>
-    obtain ⟨-, -, _, _, a1, a2, a3⟩ := ih1
-    obtain ⟨-, -, _, _, b1, b2, b3⟩ := ih2
-    have c1 := h1.toTyping; have c2 := h2.toTyping
-    exact mk (.appDF h1 h2) (.app a1 b1) (.app a2 b2) <|
-      .appDF (a1.hasType c1.2) (a2.hasType h1.symm.toTyping.2)
-        (b1.hasType c2.2) (b2.hasType h2.symm.toTyping.2) a3 b3
-  | lamDF h1 h2 ih1 ih2 =>
-    obtain ⟨-, -, _, _, a1, a2, a3⟩ := ih1
-    obtain ⟨-, -, _, _, b1, b2, b3⟩ := ih2
-    have c1 := h1.toTyping; have c2 := h2.toTyping
-    have b2' := b2.defeqDFC (.succ .zero c1.1) h2.symm.toTyping.2
-    have := TY.symm (a1.defeq c1.2)
-    exact mk (.lamDF h1 h2) (.lam a1 b1) (.lam a2 b2') <|
-      .lamDF c1.2 this (TY.trans (TY.symm a3.defeq) this) b3
-  | forallEDF h1 h2 ih1 ih2 =>
-    obtain ⟨-, -, _, _, a1, a2, a3⟩ := ih1
-    obtain ⟨-, -, _, _, b1, b2, b3⟩ := ih2
-    have c1 := h1.toTyping; have c2 := h2.toTyping
-    have b2' := b2.defeqDFC (.succ .zero c1.1) h2.symm.toTyping.2
-    exact mk (.forallEDF h1 h2) (.forallE a1 b1) (.forallE a2 b2') <|
-      .forallEDF c1.2 (TY.symm (a1.defeq c1.2)) a3 (b1.hasType c2.2) b3
-  | defeqDF _ _ _ ih2 => exact ih2
-  | beta h1 h2 ih1 ih2 =>
-    refine have h := .beta h1 h2; mk h (.tail .rfl (.beta .rfl .rfl)) .rfl ?_
-    exact .refl h.hasType.2.toTyping.2
-  | eta h1 ih1 =>
-    have := h1.toTyping.2
-    exact .normalEq <| .etaL this <| .refl <|
-      TY.app ((TY.isDefEq_weakN_iff .one).2 this) (TY.bvar .zero)
-  | proofIrrel h1 h2 h3 ih1 ih2 ih3 =>
-    exact .normalEq <| .proofIrrel h1.toTyping.2 h2.toTyping.2 h3.toTyping.2
-  | @extra _ _ Γ h1 h2 h3 =>
-    have ⟨_, _, _, _, a1, a2, a3, a4⟩ := TY.extra_pat h1 h2 h3 (Γ := Γ)
-    refine have h := .extra h1 h2 h3; mk h (.tail .rfl (.extra a1 a2 a3 fun _ => .rfl)) .rfl ?_
-    exact a4 ▸ .refl h.symm.toTyping.2
+/-! # Parked parallel-reduction prototype
+
+The maintained Church–Rosser development supersedes this prototype.  Its
+old proof depended on the removed `extra_pat` interface and induction over
+the pre-L4L-15 non-mutual judgment, and it has no consumers.  The module is
+kept as an import-compatible stub until the obsolete path is deleted at a
+repository-cleanup boundary.
+-/
diff --git a/Lean4Lean/Experimental/SExpr.lean b/Lean4Lean/Experimental/SExpr.lean
index 4204fccc..18adc38f 100644
--- a/Lean4Lean/Experimental/SExpr.lean
+++ b/Lean4Lean/Experimental/SExpr.lean
@@ -1,5 +1,6 @@
 import Lean4Lean.Theory.Typing.Lemmas
 import Lean4Lean.Theory.Typing.Pattern
+import Lean4Lean.Theory.Typing.Strong
 
 namespace Lean4Lean
 open Lean4Lean
@@ -32,11 +33,11 @@ class Params where
     p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r'
   -- pat_wf : Pat p r → p.Matches e m1 m2 → HasType env univs Γ e A →
   --   r.2.OK (IsDefEqU env univs Γ) m1 m2 → IsDefEqU env univs Γ e (r.1.apply m1 m2)
-  -- pat_app_l : Pat p r → Subpattern (.app p₁ p₂) p → ¬Subpattern (.app p₃ p₄) p₁
-  -- pat_app_l_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
-  --   Subpattern (.app p₁' p₂') p' → Subpattern (.var p₃) p₁ → p₁'.inter p₃ = none
-  -- pat_app_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
-  --   Subpattern (.app p₁' p₂') p' → Subpattern p₃ p₁ → Subpattern p₃' p₂' → p₃.inter p₃' = none
+  pat_app_l : Pat p r → Subpattern (.app p₁ p₂) p → ¬Subpattern (.app p₃ p₄) p₁
+  pat_app_l_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
+    Subpattern (.app p₁' p₂') p' → Subpattern (.var p₃) p₁ → p₁'.inter p₃ = none
+  pat_app_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
+    Subpattern (.app p₁' p₂') p' → Subpattern p₃ p₁ → Subpattern p₃' p₂' → p₃.inter p₃' = none
   -- pat_app_r_arity : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
   --   Subpattern (.app p₁' p₂') p' → Arity (.const c) n p₂ → Arity (.const c) n' p₂' → n = n'
   -- extra_pat : env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
@@ -54,6 +55,64 @@ def zero : SLevel := ⟨_, .zero, ⟨⟩, rfl⟩
 
 def mk (l : VLevel) : SLevel := if h : l.WF univs then ⟨_, l, h, rfl⟩ else .zero
 
+/-- Choose a well-formed syntactic representative of a semantic level. -/
+noncomputable def reify (l : SLevel) : VLevel := Classical.choose l.2
+
+theorem reify_wf (l : SLevel) : (reify l).WF univs :=
+  (Classical.choose_spec l.2).1
+
+theorem reify_eval (l : SLevel) : (reify l).eval = l.1 :=
+  (Classical.choose_spec l.2).2
+
+theorem mk_of_wf (h : l.WF univs) :
+    mk l = (⟨_, l, h, rfl⟩ : SLevel) := by
+  have hm : mk l = if h' : l.WF univs then
+      (⟨_, l, h', rfl⟩ : SLevel) else SLevel.zero := rfl
+  rw [hm]
+  exact dif_pos h
+
+@[simp] theorem mk_reify (l : SLevel) : mk (reify l) = l := by
+  rw [mk_of_wf (reify_wf l)]
+  apply Subtype.ext
+  exact reify_eval l
+
+theorem mk_eq (hl : l.WF univs) (hl' : l'.WF univs) (h : l ≈ l') : mk l = mk l' := by
+  rw [mk_of_wf hl, mk_of_wf hl']
+  apply Subtype.ext
+  exact VLevel.equiv_def'.1 h
+
+theorem mk_val (h : l.WF univs) : (mk l).1 = l.eval := by rw [mk_of_wf h]
+
+/-- Equality after semantic level translation reflects the source levels
+up to Lean's level equivalence.  Literal syntactic injectivity is neither
+true nor needed. -/
+theorem equiv_of_mk_eq (hl : l.WF univs) (hl' : l'.WF univs)
+    (h : mk l = mk l') : l ≈ l' := by
+  apply VLevel.equiv_def'.2
+  rw [← mk_val hl, ← mk_val hl', h]
+
+theorem forall₂_equiv_of_map_mk_eq
+    (hls : ∀ l ∈ ls, l.WF univs) (hls' : ∀ l ∈ ls', l.WF univs)
+    (h : ls.map mk = ls'.map mk) : List.Forall₂ (· ≈ ·) ls ls' := by
+  induction ls generalizing ls' with
+  | nil =>
+    cases ls' with
+    | nil => exact .nil
+    | cons => cases h
+  | cons l ls ih =>
+    cases ls' with
+    | nil => cases h
+    | cons l' ls' =>
+      simp only [List.map_cons, List.cons.injEq] at h
+      exact .cons
+        (equiv_of_mk_eq (hls l (.head _)) (hls' l' (.head _)) h.1)
+        (ih (fun x hx => hls x (.tail _ hx))
+          (fun x hx => hls' x (.tail _ hx)) h.2)
+
+@[simp] theorem mk_zero : mk .zero = zero := by
+  apply Subtype.ext
+  rfl
+
 def succ (l : SLevel) : SLevel :=
   ⟨fun v => l.1 v + 1, let ⟨u, h1, h2⟩ := l.2; ⟨u.succ, h1, h2 ▸ rfl⟩⟩
 
@@ -62,9 +121,23 @@ def max (l₁ l₂ : SLevel) : SLevel :=
     let ⟨u, h1, h2⟩ := l₁.2; let ⟨v, h3, h4⟩ := l₂.2; ⟨u.max v, ⟨h1, h3⟩, h2 ▸ h4 ▸ rfl⟩⟩
 
 def imax (l₁ l₂ : SLevel) : SLevel :=
-  ⟨fun v => (l₁.1 v).imax (l₂.1 v),
+  ⟨fun v => Lean.Nat.imax (l₁.1 v) (l₂.1 v),
     let ⟨u, h1, h2⟩ := l₁.2; let ⟨v, h3, h4⟩ := l₂.2; ⟨u.imax v, ⟨h1, h3⟩, h2 ▸ h4 ▸ rfl⟩⟩
 
+@[simp] theorem mk_succ (h : l.WF univs) : mk l.succ = succ (mk l) := by
+  have hs : l.succ.WF univs := h
+  rw [mk_of_wf hs, mk_of_wf h]; apply Subtype.ext; rfl
+
+@[simp] theorem mk_max (h1 : l₁.WF univs) (h2 : l₂.WF univs) :
+    mk (.max l₁ l₂) = max (mk l₁) (mk l₂) := by
+  rw [mk_of_wf (l := l₁.max l₂) ⟨h1, h2⟩, mk_of_wf h1, mk_of_wf h2]
+  apply Subtype.ext; rfl
+
+@[simp] theorem mk_imax (h1 : l₁.WF univs) (h2 : l₂.WF univs) :
+    mk (.imax l₁ l₂) = imax (mk l₁) (mk l₂) := by
+  rw [mk_of_wf (l := l₁.imax l₂) ⟨h1, h2⟩, mk_of_wf h1, mk_of_wf h2]
+  apply Subtype.ext; rfl
+
 def inst (ls : List SLevel) (l : SLevel) : SLevel := by
   refine ⟨fun v => l.1 (ls.map (·.1 v)), ?_⟩
   simp [funext_iff]
@@ -82,6 +155,63 @@ def inst (ls : List SLevel) (l : SLevel) : SLevel := by
     rw [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff]
     exact h3.imp fun _ _ h => congrFun h.2 _
 
+/-- Instantiate a syntactic level directly into semantic levels. Unlike `inst ls (mk l)`,
+this does not require `l` to be well-formed in the ambient universe context. -/
+def instV (ls : List SLevel) (l : VLevel) : SLevel := by
+  refine ⟨fun v => l.eval (ls.map (·.1 v)), ?_⟩
+  have ⟨ls', h⟩ :
+      ∃ ls' : List VLevel, ls'.Forall₂ (fun l' l => l'.WF univs ∧ l'.eval = l.1) ls := by
+    induction ls with
+    | nil => exact ⟨_, .nil⟩
+    | cons a ls ih =>
+      let ⟨l', h1, h2⟩ := a.2
+      let ⟨ls', ih⟩ := ih
+      exact ⟨l' :: ls', .cons ⟨h1, h2⟩ ih⟩
+  refine ⟨l.inst ls', VLevel.WF.inst fun _ hl => ?_, ?_⟩
+  · let ⟨_, hl⟩ := h.forall_exists_l _ hl; exact hl.2.1
+  · funext v
+    simp only [VLevel.eval_inst]
+    congr 1
+    rw [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff]
+    exact h.imp fun _ _ hl => congrFun hl.2 _
+
+theorem instV_map_mk (hls : ∀ u ∈ ls, u.WF univs) :
+    instV (ls.map mk) l = mk (l.inst ls) := by
+  apply Subtype.ext
+  funext ns
+  rw [congrFun (mk_val (VLevel.WF.inst hls)) ns]
+  simp only [VLevel.eval_inst]
+  change l.eval ((ls.map mk).map fun u => u.1 ns) = l.eval (ls.map (VLevel.eval ns))
+  congr 1
+  simp only [List.map_map]
+  apply List.map_congr_left
+  intro u hu
+  exact congrFun (mk_val (hls u hu)) ns
+
+theorem mk_inst (hl : l.WF univs) (hls : ∀ u ∈ ls, u.WF univs) :
+    mk (l.inst ls) = inst (ls.map mk) (mk l) := by
+  apply Subtype.ext
+  funext ns
+  rw [congrFun (mk_val (VLevel.WF.inst hls)) ns]
+  simp only [VLevel.eval_inst]
+  change l.eval (ls.map (VLevel.eval ns)) = (mk l).1 ((ls.map mk).map fun u => u.1 ns)
+  rw [congrFun (mk_val hl) _]
+  congr 1
+  simp only [List.map_map]
+  apply List.map_congr_left
+  intro u hu
+  exact (congrFun (mk_val (hls u hu)) ns).symm
+
+theorem map_mk_eq (hls : ∀ l ∈ ls, l.WF univs) (hls' : ∀ l ∈ ls', l.WF univs)
+    (h : List.Forall₂ (fun l l' => l ≈ l') ls ls') :
+    ls.map mk = ls'.map mk := by
+  induction h with
+  | nil => rfl
+  | cons h _ ih =>
+    simp only [List.map_cons]
+    rw [mk_eq (hls _ (by simp)) (hls' _ (by simp)) h,
+      ih (fun _ hu => hls _ (by simp [hu])) (fun _ hu => hls' _ (by simp [hu]))]
+
 end SLevel
 
 inductive SExpr where
@@ -157,11 +287,150 @@ def mk : VExpr → SExpr
   | .lam ty body => .lam (.mk ty) (.mk body)
   | .forallE ty body => .forallE (.mk ty) (.mk body)
 
+/-- Choose a well-formed syntactic representative of a semantic expression. -/
+noncomputable def reify : SExpr → VExpr
+  | .bvar i => .bvar i
+  | .sort u => .sort u.reify
+  | .const c us => .const c (us.map SLevel.reify)
+  | .app fn arg => .app fn.reify arg.reify
+  | .lam ty body => .lam ty.reify body.reify
+  | .forallE ty body => .forallE ty.reify body.reify
+
+@[simp] theorem mk_reify : ∀ e : SExpr, mk e.reify = e
+  | .bvar _ => rfl
+  | .sort _ => by simp [reify, mk]
+  | .const c us => by
+    simp only [reify, mk, List.map_map]
+    congr 1
+    exact List.map_id''' us fun u _ => SLevel.mk_reify u
+  | .app f a => by simp [reify, mk, mk_reify f, mk_reify a]
+  | .lam A e => by simp [reify, mk, mk_reify A, mk_reify e]
+  | .forallE A B => by simp [reify, mk, mk_reify A, mk_reify B]
+
+theorem reify_levelWF : ∀ e : SExpr, e.reify.LevelWF univs
+  | .bvar _ => trivial
+  | .sort u => u.reify_wf
+  | .const _ us => by
+    intro l hl
+    simp only [List.mem_map] at hl
+    obtain ⟨u, _, rfl⟩ := hl
+    exact u.reify_wf
+  | .app f a => ⟨reify_levelWF f, reify_levelWF a⟩
+  | .lam A e => ⟨reify_levelWF A, reify_levelWF e⟩
+  | .forallE A B => ⟨reify_levelWF A, reify_levelWF B⟩
+
+/-- `mk` is conservative on well-formed expressions modulo the source
+theory's universe-level equivalence. -/
+theorem _root_.Lean4Lean.VEnv.EqUpToLevels.of_mk_eq
+    {e e' : VExpr} (he : e.LevelWF univs) (he' : e'.LevelWF univs)
+    (h : SExpr.mk e = SExpr.mk e') : VEnv.EqUpToLevels univs e e' := by
+  induction e generalizing e' with
+  | bvar i =>
+    cases e' with
+    | bvar j => cases h; exact .bvar
+    | sort | const | app | lam | forallE => cases h
+  | sort l =>
+    cases e' with
+    | sort l' =>
+      injection h with hl
+      exact .sort he he' (SLevel.equiv_of_mk_eq he he' hl)
+    | bvar | const | app | lam | forallE => cases h
+  | const c ls =>
+    cases e' with
+    | const c' ls' =>
+      injection h with hc hls
+      subst c'
+      exact .const he he' (SLevel.forall₂_equiv_of_map_mk_eq he he' hls)
+    | bvar | sort | app | lam | forallE => cases h
+  | app f a ihf iha =>
+    cases e' with
+    | app f' a' =>
+      injection h with hf ha
+      exact .app (ihf he.1 he'.1 hf) (iha he.2 he'.2 ha)
+    | bvar | sort | const | lam | forallE => cases h
+  | lam A e ihA ihe =>
+    cases e' with
+    | lam A' e' =>
+      injection h with hA heq
+      exact .lam (ihA he.1 he'.1 hA) (ihe he.2 he'.2 heq)
+    | bvar | sort | const | app | forallE => cases h
+  | forallE A B ihA ihB =>
+    cases e' with
+    | forallE A' B' =>
+      injection h with hA hB
+      exact .forallE (ihA he.1 he'.1 hA) (ihB he.2 he'.2 hB)
+    | bvar | sort | const | app | lam => cases h
+
+theorem _root_.Lean4Lean.VEnv.EqUpToLevels.reify_mk
+    {e : VExpr} (he : e.LevelWF univs) :
+    VEnv.EqUpToLevels univs e (SExpr.reify (SExpr.mk e)) :=
+  .of_mk_eq he (SExpr.reify_levelWF (SExpr.mk e)) (SExpr.mk_reify _).symm
+
+/-- Translate an expression while instantiating its universe parameters. -/
+def mkInst (ls : List SLevel) : VExpr → SExpr
+  | .bvar i => .bvar i
+  | .sort u => .sort (.instV ls u)
+  | .const c us => .const c (us.map (.instV ls))
+  | .app fn arg => .app (mkInst ls fn) (mkInst ls arg)
+  | .lam ty body => .lam (mkInst ls ty) (mkInst ls body)
+  | .forallE ty body => .forallE (mkInst ls ty) (mkInst ls body)
+
+@[simp] theorem mkInst_lift' : mkInst ls (e.lift' ρ) = (mkInst ls e).lift' ρ := by
+  induction e generalizing ρ <;> simp [VExpr.lift', mkInst, *]
+
+theorem _root_.Lean4Lean.VExpr.ClosedN.mkInstS : ∀ {e : VExpr},
+    e.ClosedN k → (mkInst ls e).ClosedN k
+  | .bvar .., h | .sort .., h | .const .., h => h
+  | .app .., h | .lam .., h | .forallE .., h => ⟨h.1.mkInstS, h.2.mkInstS⟩
+
+theorem mkInst_map_mk (hls : ∀ u ∈ ls, u.WF univs) :
+    mkInst (ls.map SLevel.mk) e = mk (e.instL ls) := by
+  induction e with
+  | bvar => rfl
+  | sort u => exact congrArg SExpr.sort (SLevel.instV_map_mk hls)
+  | const c us =>
+    simp only [mkInst, VExpr.instL, mk, List.map_map]
+    congr 1
+    apply List.map_congr_left
+    intro u hu
+    exact SLevel.instV_map_mk hls
+  | app f a ihf iha | lam f a ihf iha | forallE f a ihf iha =>
+    simp only [mkInst, VExpr.instL, mk]
+    rw [ihf, iha]
+
+@[simp] theorem mk_lift' : ∀ {e : VExpr}, mk (e.lift' ρ) = (mk e).lift' ρ
+  | .bvar .. | .sort .. | .const .. => rfl
+  | .app .. | .lam .. | .forallE .. => by simp [VExpr.lift', mk, mk_lift']
+
+@[simp] theorem mk_lift {e : VExpr} : mk e.lift = (mk e).lift := by
+  rw [VExpr.lift_eq_lift']
+  exact mk_lift'
+
+theorem mk_instL {e : VExpr} {ls : List VLevel}
+    (he : e.LevelWF univs) (hls : ∀ u ∈ ls, u.WF univs) :
+    mk (e.instL ls) = (mk e).instL (ls.map SLevel.mk) := by
+  induction e with
+  | bvar => rfl
+  | app f a ihf iha | lam f a ihf iha | forallE f a ihf iha =>
+    simp [VExpr.LevelWF] at he
+    simp only [VExpr.instL, SExpr.mk, SExpr.instL]
+    rw [ihf he.1, iha he.2]
+  | sort u =>
+    simp only [VExpr.instL, SExpr.mk, SExpr.instL]
+    exact congrArg SExpr.sort (SLevel.mk_inst he hls)
+  | const c us =>
+    simp [VExpr.LevelWF] at he
+    simp only [VExpr.instL, mk, instL, List.map_map]
+    congr 1
+    apply List.map_congr_left
+    intro u hu
+    exact SLevel.mk_inst (he u hu) hls
+
 theorem _root_.Lean4Lean.VExpr.ClosedN.mkS : ∀ {e : VExpr}, e.ClosedN k → ClosedN (.mk e) k
   | .bvar .., h | .sort .., h | .const .., h => h
   | .app .., h | .lam .., h | .forallE .., h => ⟨h.1.mkS, h.2.mkS⟩
 
-def Subst := Nat → SExpr
+@[reducible] def Subst := Nat → SExpr
 
 def Subst.Depth (σ : Subst) (n n' : Nat) := ∀ i, σ (i + n') = .bvar (i + n)
 
@@ -256,6 +525,22 @@ def subst : SExpr → Subst → SExpr
   | .lam ty body, σ => .lam (ty.subst σ) (body.subst σ.lift)
   | .forallE ty body, σ => .forallE (ty.subst σ) (body.subst σ.lift)
 
+def mkSubst (σ : VExpr.Subst) : Subst := fun i => mk (σ i)
+
+@[simp] theorem mkSubst_lift : mkSubst σ.lift = (mkSubst σ).lift := by
+  funext i
+  cases i with
+  | zero => rfl
+  | succ i => exact mk_lift
+
+@[simp] theorem mk_subst : mk (e.subst σ) = (mk e).subst (mkSubst σ) := by
+  induction e generalizing σ with
+  | bvar => rfl
+  | sort | const => rfl
+  | app f a ihf iha => simp only [VExpr.subst, mk, subst, ihf, iha]
+  | lam A e ihA ihe | forallE A e ihA ihe =>
+    simp only [VExpr.subst, mk, subst, ihA, ihe, mkSubst_lift]
+
 @[simp] theorem id_lift : Subst.id.lift = Subst.id := by funext i; cases i <;> rfl
 
 @[simp] theorem subst_id {e : SExpr} : e.subst .id = e := by
@@ -325,6 +610,13 @@ theorem ClosedN.subst_eq {e : SExpr} (self : ClosedN e k) (h : σ.Fixes k) : e.s
 
 def inst (e a : SExpr) : SExpr := e.subst (.one a)
 
+@[simp] theorem mkSubst_one : mkSubst (VExpr.Subst.one a) = Subst.one (mk a) := by
+  funext i
+  cases i <;> rfl
+
+@[simp] theorem mk_instExpr : mk (e.inst a) = (mk e).inst (mk a) := by
+  rw [VExpr.inst_eq, inst, mk_subst, mkSubst_one]
+
 def Skips (e : SExpr) (ρ : Lift) : Prop := lift' (e.subst ρ.invS) ρ = e
 
 theorem Skips.lift (e : SExpr) (ρ : Lift) : Skips (e.lift' ρ) ρ := by
@@ -514,12 +806,249 @@ inductive _root_.Lean4Lean.Pattern.MatchesS :
   | app : MatchesS f f' f1 g1 → MatchesS a a' f2 g2 →
     MatchesS (.app f a) (.app f' a') f1 (Sum.elim g1 g2)
 
+/-- A constant application spine is matched by the corresponding `varN`
+pattern.  This is the SExpr-side constructor used when a logical-relation
+head witness exposes a recursor or constructor spine. -/
+theorem _root_.Lean4Lean.Pattern.varN_const_matchesS
+    (c : Name) (ls : List SLevel) (args : List SExpr) :
+    ∃ m2, (Pattern.varN (.const c) args.length).MatchesS
+      (args.foldr (fun a f => f.app a) (.const c ls)) ls m2 := by
+  induction args with
+  | nil =>
+    refine ⟨nofun, ?_⟩
+    refine cast ?_ (Pattern.MatchesS.const (c := c) (ls := ls))
+    simp only [List.length_nil, Pattern.varN, List.foldr_nil]
+    congr 1
+    funext path
+    exact Empty.elim path
+  | cons a args ih =>
+    obtain ⟨m2, hm⟩ := ih
+    refine ⟨fun path => Option.elim path a m2, ?_⟩
+    simpa only [List.length_cons, Pattern.varN, List.foldr_cons] using hm.var
+
+/-- Exact syntactic match for the simple recursor/iota pattern once both
+constant-headed spines and their arities are known. -/
+theorem _root_.Lean4Lean.RecursorIotaPattern.matchesS_spines
+    {r c : Name} {rls cls : List SLevel} {rargs cargs : List SExpr}
+    {major ctorArity : Nat}
+    (hr : rargs.length = major) (hc : cargs.length = ctorArity) :
+    ∃ m2, (RecursorIotaPattern r major c ctorArity).MatchesS
+      (.app (rargs.foldr (fun a f => f.app a) (.const r rls))
+        (cargs.foldr (fun a f => f.app a) (.const c cls))) rls m2 := by
+  obtain ⟨mr, hmr⟩ := Pattern.varN_const_matchesS r rls rargs
+  obtain ⟨mc, hmc⟩ := Pattern.varN_const_matchesS c cls cargs
+  subst major
+  subst ctorArity
+  exact ⟨Sum.elim mr mc, hmr.app hmc⟩
+
+/-- Invert a `varN` match headed by a constant into the exact application
+spine it inspected.  Besides the arity equation, retain the capture map and
+its original match proof so dependent consumers do not have to reconstruct
+either one from list indexing. -/
+theorem _root_.Lean4Lean.Pattern.MatchesS.varN_const_inv
+    (H : (Pattern.varN (.const c) arity).MatchesS e ls mcap) :
+    ∃ (args : List SExpr),
+      args.length = arity ∧
+      e = args.foldr (fun a f => f.app a) (.const c ls) ∧
+      (Pattern.varN (.const c) arity).MatchesS
+        (args.foldr (fun a f => f.app a) (.const c ls)) ls mcap := by
+  induction arity generalizing e with
+  | zero =>
+    simp only [Pattern.varN] at H ⊢
+    cases H
+    exact ⟨[], rfl, rfl, .const⟩
+  | succ arity ih =>
+    simp only [Pattern.varN] at H ⊢
+    cases H with
+    | @var f f' f1 g1 a' h =>
+      obtain ⟨args, hlen, rfl, hmatch⟩ := ih h
+      exact ⟨a' :: args, congrArg Nat.succ hlen, rfl, hmatch.var⟩
+
+/-- Exact decomposition of a semantic iota match.  In particular this
+recovers the constructor universe levels, which are not stored in the
+match's `m1` index, and separates the recursor and constructor capture maps.
+Generated-rule soundness must validate those recovered levels against its
+rule certificate before constructing a contraction. -/
+theorem _root_.Lean4Lean.Pattern.MatchesS.iota_inv
+    {rec ctor : Name} {major arity : Nat} {e : SExpr}
+    {recLs : List SLevel}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    (H : (RecursorIotaPattern rec major ctor arity).MatchesS e recLs mcap) :
+    ∃ (recArgs ctorArgs : List SExpr) (ctorLs : List SLevel)
+        (mrec : (Pattern.varN (.const rec) major).Path → SExpr)
+        (mctor : (Pattern.varN (.const ctor) arity).Path → SExpr),
+      recArgs.length = major ∧ ctorArgs.length = arity ∧
+      e = (recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)) ∧
+      mcap = Sum.elim mrec mctor ∧
+      (Pattern.varN (.const rec) major).MatchesS
+        (recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)) recLs mrec ∧
+      (Pattern.varN (.const ctor) arity).MatchesS
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)) ctorLs mctor := by
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨recArgs, hrecLen, rfl, hrec'⟩ := hrec.varN_const_inv
+    obtain ⟨ctorArgs, hctorLen, rfl, hctor'⟩ := hctor.varN_const_inv
+    exact ⟨recArgs, ctorArgs, ctorLevels, recCap, ctorCap,
+      hrecLen, hctorLen, rfl, rfl, hrec', hctor'⟩
+
+/-- A successful syntactic match remembers the constant-headed application
+spine that it inspected. Arguments are stored in reverse application order,
+matching the representation used by the shape interpretation. -/
+theorem _root_.Lean4Lean.Pattern.MatchesS.head_spine (H : p.MatchesS e ls m) :
+    ∃ (c : Name) (ls' : List SLevel) (args : List SExpr),
+      e = args.foldr (fun a f => f.app a) (.const c ls') ∧
+      Arity (.const c) args.length p := by
+  induction H with
+  | const => exact ⟨_, _, [], rfl, .refl⟩
+  | @var f f' f1 g1 a' h ih =>
+    obtain ⟨c, ls, args, heq, har⟩ := ih
+    refine ⟨c, ls, a' :: args, ?_, .var har⟩
+    simp only [List.foldr_cons]
+    rw [← heq]
+  | @app f f' f1 g1 a a' f2 g2 hf ha ihf iha =>
+    obtain ⟨c, ls, args, heq, har⟩ := ihf
+    refine ⟨c, ls, a' :: args, ?_, .app har⟩
+    simp only [List.foldr_cons]
+    rw [← heq]
+
+theorem _root_.Lean4Lean.Pattern.matchesS_inter {p q : Pattern} {e : SExpr} :
+    (∃ m1 m2, p.MatchesS e m1 m2) ∧ (∃ m1 m2, q.MatchesS e m1 m2) ↔
+    (∃ r m1 m2, p.inter q = some r ∧ r.MatchesS e m1 m2) := by
+  constructor
+  · rintro ⟨⟨m1, m2, hp⟩, ⟨m3, m4, hq⟩⟩
+    induction hp generalizing q m3 <;> cases hq <;> simp [Pattern.inter]
+    · case const.const => exact ⟨_, _, .const⟩
+    · case var.var ih _ _ ih' =>
+      have ⟨rf, mf1, mf2, hf1, hf2⟩ := ih _ _ ih'
+      exact ⟨_, ⟨_, hf1, rfl⟩, _, _, .var hf2⟩
+    · case var.app ihf _ _ _ _ _ ha2 ihf' =>
+      have ⟨rf, mf1, mf2, hf1, hf2⟩ := ihf _ _ ihf'
+      exact ⟨_, ⟨_, hf1, rfl⟩, _, _, .app hf2 ha2⟩
+    · case app.var ha2 ihf _ _ _ ihf' =>
+      have ⟨rf, mf1, mf2, hf1, hf2⟩ := ihf _ _ ihf'
+      exact ⟨_, ⟨_, hf1, rfl⟩, _, _, .app hf2 ha2⟩
+    · case app.app ihf iha _ _ _ _ _ iha' ihf' =>
+      have ⟨rf, mf1, mf2, hf1, hf2⟩ := ihf _ _ ihf'
+      have ⟨ra, ma1, ma2, ha1, ha2⟩ := iha _ _ iha'
+      exact ⟨_, ⟨_, hf1, _, ha1, rfl⟩, _, _, .app hf2 ha2⟩
+  · rintro ⟨r, m1, m2, h1, h2⟩
+    induction p generalizing q e r m1 <;> cases q <;> simp [Pattern.inter] at h1 <;> [
+        obtain ⟨rfl, rfl⟩ := h1; obtain ⟨_, wf, _, wa, rfl⟩ := h1;
+        obtain ⟨_, wf, rfl⟩ := h1; obtain ⟨_, wf, rfl⟩ := h1; obtain ⟨_, wf, rfl⟩ := h1
+      ] <;> cases h2
+    · exact ⟨⟨_, _, .const⟩, ⟨_, _, .const⟩⟩
+    · next ihf iha _ _ _ _ _ _ _ _ _ ha hf =>
+      have ⟨⟨mf1, mf2, hf⟩, ⟨mf1', mf2', hf'⟩⟩ := ihf _ _ _ wf hf
+      have ⟨⟨ma1, ma2, ha⟩, ⟨ma1', ma2', ha'⟩⟩ := iha _ _ _ wa ha
+      exact ⟨⟨_, _, .app hf ha⟩, ⟨_, _, .app hf' ha'⟩⟩
+    · next ihf _ _ _ _ _ _ _ _ ha hf =>
+      have ⟨⟨mf1, mf2, hf⟩, ⟨mf1', mf2', hf'⟩⟩ := ihf _ _ _ wf hf
+      exact ⟨⟨_, _, .app hf ha⟩, ⟨_, _, .var hf'⟩⟩
+    · next ihf _ _ _ _ _ _ _ _ ha' hf =>
+      have ⟨⟨mf1, mf2, hf⟩, ⟨mf1', mf2', hf'⟩⟩ := ihf _ _ _ wf hf
+      exact ⟨⟨_, _, .var hf⟩, ⟨_, _, .app hf' ha'⟩⟩
+    · next ihf _ _ _ _ _ hf =>
+      have ⟨⟨mf1, mf2, hf⟩, ⟨mf1', mf2', hf'⟩⟩ := ihf _ _ _ wf hf
+      exact ⟨⟨_, _, .var hf⟩, ⟨_, _, .var hf'⟩⟩
+
+theorem _root_.Lean4Lean.Pattern.MatchesS.determ
+    (h1 : Pattern.MatchesS p e m1 m2) (h2 : Pattern.MatchesS p e m1' m2') :
+    m1 = m1' ∧ m2 = m2' := by
+  induction h1 generalizing m1' with
+  | const => let .const := h2; simp
+  | app l1 l2 ih1 ih2 => let .app r1 r2 := h2; simp [ih1 r1, ih2 r2]
+  | var l1 ih1 => let .var r1 := h2; simp [ih1 r1]
+
+/-- Reify a semantic match into an exact syntactic match. -/
+theorem _root_.Lean4Lean.Pattern.MatchesS.reify
+    (H : Pattern.MatchesS p e m1 m2) :
+    Pattern.Matches p e.reify (m1.map SLevel.reify)
+      fun path => (m2 path).reify := by
+  induction H with
+  | @const c ls =>
+    refine cast ?_ (Pattern.Matches.const
+      (c := c) (ls := ls.map SLevel.reify))
+    simp only [SExpr.reify]
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f1 g1 a' _ ih =>
+    change Pattern.Matches (.var f) (.app f'.reify a'.reify)
+      (f1.map SLevel.reify) fun path => (Option.elim path a' g1).reify
+    have heq : (fun path => (Option.elim path a' g1).reify) =
+        (fun path => Option.elim path a'.reify fun path => (g1 path).reify) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f1 g1 a a' f2 g2 _ _ ihf iha =>
+    change Pattern.Matches (.app f a) (.app f'.reify a'.reify)
+      (f1.map SLevel.reify) fun path => (Sum.elim g1 g2 path).reify
+    have heq : (fun path => (Sum.elim g1 g2 path).reify) =
+        Sum.elim (fun path => (g1 path).reify)
+          (fun path => (g2 path).reify) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ihf.app iha
+
 def _root_.Lean4Lean.Pattern.RHS.applyS {p : Pattern}
     (m1 : List SLevel) (m2 : p.Path → SExpr) : p.RHS → SExpr
-  | .fixed c _ => .instL m1 (.mk c)
+  | .fixed c _ => .mkInst m1 c
   | .var path => m2 path
   | .app f a => .app (f.applyS m1 m2) (a.applyS m1 m2)
 
+/-- Applying a left-associated RHS application tower is the corresponding
+left fold of the instantiated template arguments. -/
+theorem _root_.Lean4Lean.Pattern.RHS.appN_applyS {p : Pattern}
+    (f : p.RHS) (as : List p.RHS) (m1 : List SLevel)
+    (m2 : p.Path → SExpr) :
+    (Pattern.RHS.appN f as).applyS m1 m2 =
+      as.foldl (fun acc a => acc.app (a.applyS m1 m2))
+        (f.applyS m1 m2) := by
+  induction as generalizing f with
+  | nil => rfl
+  | cons a as ih =>
+    simpa only [Pattern.RHS.appN, Pattern.RHS.applyS,
+      List.foldl_cons] using ih (.app f a)
+
+/-- Expose the last application in an RHS application tower. -/
+theorem _root_.Lean4Lean.Pattern.RHS.appN_append_singleton {p : Pattern}
+    (f a : p.RHS) (as : List p.RHS) :
+    Pattern.RHS.appN f (as ++ [a]) = .app (Pattern.RHS.appN f as) a := by
+  induction as generalizing f with
+  | nil => rfl
+  | cons b as ih =>
+    simpa only [List.cons_append, Pattern.RHS.appN] using ih (.app f b)
+
+/-- Reification commutes with applying a pattern RHS, up to the semantic
+quotient map. -/
+theorem _root_.Lean4Lean.Pattern.RHS.mk_apply_reify {p : Pattern}
+    (r : p.RHS) (m1 : List SLevel) (m2 : p.Path → SExpr) :
+    SExpr.mk (r.apply (m1.map SLevel.reify) fun path => (m2 path).reify) =
+      r.applyS m1 m2 := by
+  induction r with
+  | fixed e closed =>
+    simp only [Pattern.RHS.apply, Pattern.RHS.applyS]
+    rw [← SExpr.mkInst_map_mk
+      (ls := m1.map SLevel.reify) (e := e)
+      (by
+        intro l hl
+        simp only [List.mem_map] at hl
+        obtain ⟨u, _, rfl⟩ := hl
+        exact u.reify_wf)]
+    congr 1
+    rw [List.map_map]
+    apply List.map_id'''
+    intro u _
+    exact SLevel.mk_reify u
+  | var path => exact SExpr.mk_reify (m2 path)
+  | app f a ihf iha =>
+    simp only [Pattern.RHS.apply, Pattern.RHS.applyS, SExpr.mk]
+    rw [ihf, iha]
+
 def _root_.Lean4Lean.Pattern.RHS.Closed {p : Pattern} : p.RHS → Prop
   | .fixed c _ => c.Closed
   | .var _ => True
@@ -527,7 +1056,7 @@ def _root_.Lean4Lean.Pattern.RHS.Closed {p : Pattern} : p.RHS → Prop
 
 def _root_.Lean4Lean.Pattern.RHS.Closed.applyS {p : Pattern} {m1 m2} :
     ∀ r : p.RHS, r.Closed → (∀ a, (m2 a).ClosedN k) → (r.applyS m1 m2).ClosedN k
-  | .fixed .., h1, _ => h1.mkS.instL.mono (Nat.zero_le _)
+  | .fixed .., h1, _ => h1.mkInstS.mono (Nat.zero_le _)
   | .var _, _, h2 => h2 _
   | .app .., h1, h2 => ⟨h1.1.applyS _ h2, h1.2.applyS _ h2⟩
 
@@ -536,6 +1065,142 @@ def _root_.Lean4Lean.Pattern.Check.defeqsS {p : Pattern}
   | .true => []
   | .defeq a b rest => (a.applyS m1 m2, b.applyS m1 m2) :: rest.defeqsS m1 m2
 
+theorem _root_.Lean4Lean.Pattern.MatchesS.lift'
+    (H : Pattern.MatchesS p e m1 m2) :
+    Pattern.MatchesS p (e.lift' ρ) m1 fun path => (m2 path).lift' ρ := by
+  induction H with
+  | @const c ls =>
+    refine cast ?_ (Pattern.MatchesS.const (c := c) (ls := ls))
+    simp only [SExpr.lift']
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f1 g1 a' _ ih =>
+    change Pattern.MatchesS (.var f) (.app (f'.lift' ρ) (a'.lift' ρ)) f1
+      (fun path => (Option.elim path a' g1).lift' ρ)
+    have heq : (fun path => (Option.elim path a' g1).lift' ρ) =
+        (fun path => Option.elim path (a'.lift' ρ) fun path => (g1 path).lift' ρ) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f1 g1 a a' f2 g2 _ _ ih1 ih2 =>
+    change Pattern.MatchesS (.app f a) (.app (f'.lift' ρ) (a'.lift' ρ)) f1
+      (fun path => (Sum.elim g1 g2 path).lift' ρ)
+    have heq : (fun path => (Sum.elim g1 g2 path).lift' ρ) =
+        Sum.elim (fun path => (g1 path).lift' ρ) (fun path => (g2 path).lift' ρ) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih1.app ih2
+
+theorem _root_.Lean4Lean.Pattern.RHS.lift'_applyS {p : Pattern}
+    (r : p.RHS) (m1 : List SLevel) (m2 : p.Path → SExpr) :
+    (r.applyS m1 m2).lift' ρ = r.applyS m1 fun path => (m2 path).lift' ρ := by
+  induction r with
+  | fixed e cl => exact (cl.mkInstS.lift'_eq .zero)
+  | var => rfl
+  | app _ _ ih1 ih2 =>
+    simp only [Pattern.RHS.applyS, SExpr.lift']
+    rw [ih1, ih2]
+
+theorem _root_.Lean4Lean.Pattern.Check.defeqsS_lift' {p : Pattern}
+    (ck : p.Check) (m1 : List SLevel) (m2 : p.Path → SExpr) :
+    (ck.defeqsS m1 m2).map (fun ab => (ab.1.lift' ρ, ab.2.lift' ρ)) =
+      ck.defeqsS m1 fun path => (m2 path).lift' ρ := by
+  induction ck with
+  | true => rfl
+  | defeq a b rest ih =>
+    simp only [Pattern.Check.defeqsS, List.map_cons, ih]
+    rw [a.lift'_applyS, b.lift'_applyS]
+
+theorem _root_.Lean4Lean.Pattern.matchesS_lift' {p : Pattern} {e : SExpr} {m1 m2'} :
+    p.MatchesS (e.lift' ρ) m1 m2' ↔
+    ∃ m2, p.MatchesS e m1 m2 ∧ ∀ path, m2' path = (m2 path).lift' ρ := by
+  constructor
+  · intro h
+    generalize eq : e.lift' ρ = e' at h
+    induction h generalizing e with
+    | const => cases e <;> cases eq; exact ⟨_, .const, nofun⟩
+    | var _ ih =>
+      cases e <;> cases eq
+      have ⟨_, hmatch, hpath⟩ := ih rfl
+      refine ⟨_, .var hmatch, ?_⟩
+      intro path
+      cases path <;> simp_all
+    | app _ _ ihf iha =>
+      cases e <;> cases eq
+      have ⟨_, hf, hfp⟩ := ihf rfl
+      have ⟨_, ha, hap⟩ := iha rfl
+      refine ⟨_, .app hf ha, ?_⟩
+      intro path
+      cases path <;> simp_all
+  · rintro ⟨m2, hmatch, hpath⟩
+    induction hmatch with
+    | const => exact (show m2' = _ by ext path; exact Empty.elim path) ▸ .const
+    | @var f f' f1 g1 a' _ ih =>
+      have h := ih (hpath <| some ·)
+      have heq : m2' = fun path => Option.elim path (a'.lift' ρ) fun path => m2' (some path) := by
+        funext path
+        cases path <;> simp [hpath]
+      rw [heq]
+      exact h.var
+    | app _ _ ihf iha =>
+      have h := (ihf (hpath <| .inl ·)).app (iha (hpath <| .inr ·))
+      refine cast ?_ h
+      congr 1
+      funext path
+      cases path <;> rfl
+
+theorem _root_.Lean4Lean.Pattern.MatchesS.subst
+    (H : Pattern.MatchesS p e m1 m2) :
+    Pattern.MatchesS p (e.subst σ) m1 fun path => (m2 path).subst σ := by
+  induction H with
+  | @const c ls =>
+    refine cast ?_ (Pattern.MatchesS.const (c := c) (ls := ls))
+    simp only [SExpr.subst]
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f1 g1 a' _ ih =>
+    change Pattern.MatchesS (.var f) (.app (f'.subst σ) (a'.subst σ)) f1
+      (fun path => (Option.elim path a' g1).subst σ)
+    have heq : (fun path => (Option.elim path a' g1).subst σ) =
+        (fun path => Option.elim path (a'.subst σ) fun path => (g1 path).subst σ) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f1 g1 a a' f2 g2 _ _ ih1 ih2 =>
+    change Pattern.MatchesS (.app f a) (.app (f'.subst σ) (a'.subst σ)) f1
+      (fun path => (Sum.elim g1 g2 path).subst σ)
+    have heq : (fun path => (Sum.elim g1 g2 path).subst σ) =
+        Sum.elim (fun path => (g1 path).subst σ) (fun path => (g2 path).subst σ) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih1.app ih2
+
+theorem _root_.Lean4Lean.Pattern.RHS.subst_applyS {p : Pattern}
+    (r : p.RHS) (m1 : List SLevel) (m2 : p.Path → SExpr) :
+    (r.applyS m1 m2).subst σ = r.applyS m1 fun path => (m2 path).subst σ := by
+  induction r with
+  | fixed e cl => exact cl.mkInstS.subst_eq .zero
+  | var => rfl
+  | app _ _ ih1 ih2 =>
+    simp only [Pattern.RHS.applyS, SExpr.subst]
+    rw [ih1, ih2]
+
+theorem _root_.Lean4Lean.Pattern.Check.defeqsS_subst {p : Pattern}
+    (ck : p.Check) (m1 : List SLevel) (m2 : p.Path → SExpr) :
+    (ck.defeqsS m1 m2).map (fun ab => (ab.1.subst σ, ab.2.subst σ)) =
+      ck.defeqsS m1 fun path => (m2 path).subst σ := by
+  induction ck with
+  | true => rfl
+  | defeq a b rest ih =>
+    simp only [Pattern.Check.defeqsS, List.map_cons, ih]
+    rw [a.subst_applyS, b.subst_applyS]
+
 section
 set_option hygiene false
 
@@ -543,6 +1208,11 @@ inductive Lookup : List SExpr → Nat → SExpr → Prop where
   | zero : Lookup (ty::Γ) 0 ty.lift
   | succ : Lookup Γ n ty → Lookup (A::Γ) (n+1) ty.lift
 
+theorem Lookup.mkS (H : Lean4Lean.Lookup Γ i A) : Lookup (Γ.map mk) i (mk A) := by
+  induction H with
+  | zero => rw [mk_lift]; exact .zero
+  | succ _ ih => rw [mk_lift]; exact .succ ih
+
 theorem Lookup.weak' (W : Ctx.Lift' ρ Γ Γ') (H : Lookup Γ i A) :
     Lookup Γ' (ρ.liftVar i) (A.lift' ρ) := by
   induction W generalizing i A with
@@ -591,11 +1261,9 @@ inductive IsDefEq : List SExpr → SExpr → SExpr → SExpr → Prop where
   | bvar : Lookup Γ i A → Γ ⊢ .bvar i : A
   | symm : Γ ⊢ e ≡ e' : A → Γ ⊢ e' ≡ e : A
   | trans : Γ ⊢ e₁ ≡ e₂ : A → Γ ⊢ e₂ ≡ e₃ : A → Γ ⊢ e₁ ≡ e₃ : A
-  /-- Heterogeneous transitivity: middle term may be at a different sort. -/
-  | trans' : Γ ⊢ A ≡ B : .sort u → Γ ⊢ B ≡ C : .sort v → Γ ⊢ A ≡ C : .sort u
   | sort : Γ ⊢ .sort l : .sort (.succ l)
   | const : env.constants c = some ci → ls.length = ci.uvars →
-    Γ ⊢ .const c ls : (SExpr.mk ci.type).instL ls
+    Γ ⊢ .const c ls : SExpr.mkInst ls ci.type
   | appDF : Γ ⊢ f ≡ f' : .forallE A B → Γ ⊢ a ≡ a' : A →
     Γ ⊢ .app f a ≡ .app f' a' : B.inst a
   | lamDF : Γ ⊢ A ≡ A' : .sort u → A::Γ ⊢ body ≡ body' : B →
@@ -609,13 +1277,606 @@ inductive IsDefEq : List SExpr → SExpr → SExpr → SExpr → Prop where
   -- | extra : Pat p r → p.MatchesS e m1 m2 → (dfs : List _).map (·.2) = r.2.defeqsS m1 m2 →
   --   (∀ a b A, (A, a, b) ∈ dfs → Γ ⊢ a ≡ b : A) → Γ ⊢ e ≡ r.1.applyS m1 m2' : A
   | extra : env.defeqs df → ls.length = df.uvars →
-    Γ ⊢ .instL ls (.mk df.lhs) ≡ .instL ls (.mk df.rhs) : .instL ls (.mk df.type)
+    Γ ⊢ .mkInst ls df.lhs ≡ .mkInst ls df.rhs : .mkInst ls df.type
+
+/-- The universe list of a constant at the head of `e` has the arity
+registered for that constant. -/
+def HeadConstLevelsWF (e : SExpr) : Prop :=
+  ∀ {c ls ci}, e = .const c ls → Params.env.constants c = some ci →
+    ls.length = ci.uvars
+
+private theorem HeadConstLevelsWF.nonconst
+    (h : ∀ {c ls}, e ≠ .const c ls) : HeadConstLevelsWF e := by
+  intro c ls ci heq
+  exact (h heq).elim
+
+/-- Head-constant arity is preserved by term instantiation.  The only
+nontrivial case is a substituted bound variable, whose result is the
+instantiating argument itself. -/
+theorem HeadConstLevelsWF.inst
+    (he : HeadConstLevelsWF e) (ha : HeadConstLevelsWF a) :
+    HeadConstLevelsWF (e.inst a) := by
+  induction e with
+  | bvar i =>
+    cases i with
+    | zero => exact ha
+    | succ i =>
+      refine HeadConstLevelsWF.nonconst ?_
+      intro c ls heq
+      change SExpr.bvar i = SExpr.const c ls at heq
+      cases heq
+  | const => exact he
+  | sort | app | lam | forallE =>
+    exact HeadConstLevelsWF.nonconst (by simp [SExpr.inst, SExpr.subst])
+
+/-- A well-typed closed source expression instantiated into semantic levels
+has a well-formed head constant. -/
+private theorem HeadConstLevelsWF.mkInst_of_hasType
+    (H : Params.env.HasType U [] e A) :
+    HeadConstLevelsWF (SExpr.mkInst ls e) := by
+  intro c levels ci heq hci
+  cases e with
+  | bvar | sort | app | lam | forallE => cases heq
+  | const c' sourceLevels =>
+    simp only [SExpr.mkInst] at heq
+    injection heq with hc hlevels
+    subst c'
+    obtain ⟨ci', hci', _, hlen⟩ :=
+      VEnv.HasType.const_inv Params.henv (by trivial) H
+    have hciEq : ci' = ci := Option.some.inj (hci'.symm.trans hci)
+    rw [← hciEq]
+    rw [← hlen, ← hlevels, List.length_map]
+
+/-- Both endpoints of a weak definitional equality have well-formed head
+constant levels.  This survives beta substitution and raw registered
+equations, the two cases not covered by a shallow constructor inversion. -/
+theorem IsDefEq.headConstLevelsWF
+    (H : IsDefEq Γ e₁ e₂ A) :
+    HeadConstLevelsWF e₁ ∧ HeadConstLevelsWF e₂ := by
+  induction H with
+  | bvar =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.nonconst (by simp)⟩
+  | symm _ ih => exact ih.symm
+  | trans _ _ ih₁ ih₂ => exact ⟨ih₁.1, ih₂.2⟩
+  | sort =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.nonconst (by simp)⟩
+  | const hreg hlen =>
+    constructor <;> intro c' ls' ci' heq hreg'
+    all_goals
+      injection heq with hc hls
+      subst c'; subst ls'
+      have hciEq : _ = ci' := Option.some.inj (hreg.symm.trans hreg')
+      simpa [hciEq] using hlen
+  | appDF =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.nonconst (by simp)⟩
+  | lamDF =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.nonconst (by simp)⟩
+  | forallEDF =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.nonconst (by simp)⟩
+  | defeqDF _ _ _ ih => exact ih
+  | beta _ _ ihBody ihArg =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp),
+      HeadConstLevelsWF.inst ihBody.1 ihArg.1⟩
+  | eta _ ih =>
+    exact ⟨HeadConstLevelsWF.nonconst (by simp), ih.1⟩
+  | proofIrrel _ _ _ _ ihLeft ihRight => exact ⟨ihLeft.1, ihRight.1⟩
+  | extra hreg _ =>
+    have hwf := Params.henv.defEqWF hreg
+    exact ⟨HeadConstLevelsWF.mkInst_of_hasType hwf.1,
+      HeadConstLevelsWF.mkInst_of_hasType hwf.2⟩
+
+/-- Invert weak equality at a constant left endpoint to recover the exact
+universe-list arity required by its registered declaration. -/
+theorem IsDefEq.const_left_levelsLength
+    (H : IsDefEq Γ (.const c ls) e A)
+    (hci : Params.env.constants c = some ci) :
+    ls.length = ci.uvars :=
+  H.headConstLevelsWF.1 rfl hci
+
+/-- Symmetric endpoint form of `const_left_levelsLength`. -/
+theorem IsDefEq.const_right_levelsLength
+    (H : IsDefEq Γ e (.const c ls) A)
+    (hci : Params.env.constants c = some ci) :
+    ls.length = ci.uvars :=
+  H.headConstLevelsWF.2 rfl hci
+
+/-- SExpr-side typing of an exact application spine.  Unlike a bare typing
+of the final application, this retains the type of every argument at the
+point where its surrounding pi is peeled.  Generated iota soundness needs
+this evidence for the recursor, constructor, and captured-rule spines. -/
+inductive SpineWF (Γ : List SExpr) : SExpr → List SExpr → SExpr → Prop where
+  | nil : SpineWF Γ A [] A
+  | cons :
+    IsDefEq Γ e e A₁ →
+    SpineWF Γ (A₂.inst e) es B →
+    SpineWF Γ (.forallE A₁ A₂) (e :: es) B
+  | conv :
+    IsDefEq Γ A A' (.sort u) →
+    SpineWF Γ A' es B →
+    SpineWF Γ A es B
+  | ret :
+    SpineWF Γ A es B →
+    IsDefEq Γ B B' (.sort u) →
+    SpineWF Γ A es B'
+
+/-- Concatenate conversion-aware spines without composing their result-type
+conversions.  In the `ret` case the retained conversion is moved to the
+head of the second spine.  This is the structural replacement for the old
+heterogeneous `IsDefEq.trans'` rule: no equality between the two sort
+indices is needed or assumed. -/
+theorem SpineWF.append
+    (H₁ : SpineWF Γ A es B) (H₂ : SpineWF Γ B fs C) :
+    SpineWF Γ A (es ++ fs) C := by
+  induction H₁ with
+  | nil => simpa using H₂
+  | cons harg _ ih => exact .cons harg (ih H₂)
+  | conv hty _ ih => exact .conv hty (ih H₂)
+  | ret _ hret ih => exact ih (.conv hret H₂)
+
+/-- Extend a conversion-aware spine by its final argument. -/
+theorem SpineWF.snoc
+    (H : SpineWF Γ A es B)
+    (hB : IsDefEq Γ B (.forallE D C) (.sort u))
+    (he : IsDefEq Γ e e D) :
+    SpineWF Γ A (es ++ [e]) (C.inst e) :=
+  H.append (.conv hB (.cons he .nil))
+
+/-- Two application spines with a common final Pi layer.  The explicit
+codomain conversions are deliberately retained for both majors: they let a
+consumer combine either recursor prefix with either endpoint of a related
+major without appealing to global type uniqueness. -/
+structure SpineWF.LastPair (Γ : List SExpr) (Head : SExpr)
+    (xs ys : List SExpr) (x y A : SExpr) where
+  prefixType : SExpr
+  domain : SExpr
+  codomain : SExpr
+  piSort : SLevel
+  resultSortX : SLevel
+  resultSortY : SLevel
+  prefixX : SpineWF Γ Head xs.reverse prefixType
+  prefixY : SpineWF Γ Head ys.reverse prefixType
+  pi : IsDefEq Γ prefixType (.forallE domain codomain) (.sort piSort)
+  major : IsDefEq Γ x y domain
+  resultX : IsDefEq Γ (codomain.inst x) A (.sort resultSortX)
+  resultY : IsDefEq Γ (codomain.inst y) A (.sort resultSortY)
+
+/-- Recover the complete left application spine. -/
+theorem SpineWF.LastPair.fullX
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF Γ Head (x :: xs).reverse A := by
+  rw [List.reverse_cons]
+  exact .ret (H.prefixX.snoc H.pi (H.major.trans H.major.symm)) H.resultX
+
+/-- Recover the complete right application spine. -/
+theorem SpineWF.LastPair.fullY
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF Γ Head (y :: ys).reverse A := by
+  rw [List.reverse_cons]
+  exact .ret (H.prefixY.snoc H.pi (H.major.symm.trans H.major)) H.resultY
+
+/-- Keep the major pair and use the left prefix at both endpoints. -/
+def SpineWF.LastPair.leftPrefixes
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head xs xs x y A :=
+  { H with prefixY := H.prefixX }
+
+/-- Keep the major pair and use the right prefix at both endpoints. -/
+def SpineWF.LastPair.rightPrefixes
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head ys ys x y A :=
+  { H with prefixX := H.prefixY }
+
+/-- Swap only the two recursor prefixes. -/
+def SpineWF.LastPair.symmPrefixes
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head ys xs x y A :=
+  { H with prefixX := H.prefixY, prefixY := H.prefixX }
+
+/-- Keep the prefixes and use the left major at both endpoints. -/
+def SpineWF.LastPair.leftMajors
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head xs ys x x A :=
+  { H with
+    major := H.major.trans H.major.symm
+    resultSortY := H.resultSortX
+    resultY := H.resultX }
+
+/-- Keep the prefixes and use the right major at both endpoints. -/
+def SpineWF.LastPair.rightMajors
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head xs ys y y A :=
+  { H with
+    major := H.major.symm.trans H.major
+    resultSortX := H.resultSortY
+    resultX := H.resultY }
+
+/-- Swap both prefixes and majors. -/
+def SpineWF.LastPair.symm
+    (H : SpineWF.LastPair Γ Head xs ys x y A) :
+    SpineWF.LastPair Γ Head ys xs y x A :=
+  { H with
+    prefixX := H.prefixY
+    prefixY := H.prefixX
+    major := H.major.symm
+    resultSortX := H.resultSortY
+    resultSortY := H.resultSortX
+    resultX := H.resultY
+    resultY := H.resultX }
+
+/-- Packaging of the final-application certificate for callers that keep
+their accumulated spines as whole lists. -/
+structure SpineWF.NonemptyLastPair (Γ : List SExpr) (Head : SExpr)
+    (args args' : List SExpr) (A : SExpr) where
+  x : SExpr
+  xs : List SExpr
+  y : SExpr
+  ys : List SExpr
+  args_eq : args = x :: xs
+  args'_eq : args' = y :: ys
+  pair : SpineWF.LastPair Γ Head xs ys x y A
+
+/-- Apply a certified spine to a term typed at its head type. -/
+theorem SpineWF.hasType
+    (H : SpineWF Γ A es B) (hf : IsDefEq Γ f f A) :
+    IsDefEq Γ (es.foldl (fun f a => f.app a) f)
+      (es.foldl (fun f a => f.app a) f) B := by
+  induction H generalizing f with
+  | nil => exact hf
+  | cons he _ ih =>
+    simp only [List.foldl_cons]
+    exact ih (.appDF hf he)
+  | conv hty _ ih => exact ih (hty.defeqDF hf)
+  | ret _ hty ih => exact hty.defeqDF (ih hf)
+
+/-- Self-typing of the complete left application. -/
+theorem SpineWF.LastPair.hasTypeX
+    (H : SpineWF.LastPair Γ Head xs ys x y A)
+    (hhead : IsDefEq Γ f f Head) :
+    IsDefEq Γ ((x :: xs).foldr (fun a f => f.app a) f)
+      ((x :: xs).foldr (fun a f => f.app a) f) A := by
+  simpa only [List.foldl_reverse, List.foldr_cons] using H.fullX.hasType hhead
+
+/-- Self-typing of the complete right application. -/
+theorem SpineWF.LastPair.hasTypeY
+    (H : SpineWF.LastPair Γ Head xs ys x y A)
+    (hhead : IsDefEq Γ f f Head) :
+    IsDefEq Γ ((y :: ys).foldr (fun a f => f.app a) f)
+      ((y :: ys).foldr (fun a f => f.app a) f) A := by
+  simpa only [List.foldl_reverse, List.foldr_cons] using H.fullY.hasType hhead
+
+/-- Apply a certified spine congruently to both endpoints of a typed
+equality.  This is the SExpr counterpart of Theory's `appN_congr`; retaining
+the spine certificate avoids reconstructing the intermediate pi types. -/
+theorem SpineWF.congr
+    (H : SpineWF Γ A es B) (hf : IsDefEq Γ f f' A) :
+    IsDefEq Γ (es.foldl (fun f a => f.app a) f)
+      (es.foldl (fun f a => f.app a) f') B := by
+  induction H generalizing f f' with
+  | nil => exact hf
+  | cons he _ ih =>
+    simp only [List.foldl_cons]
+    exact ih (.appDF hf he)
+  | conv hty _ ih => exact ih (hty.defeqDF hf)
+  | ret _ hty ih => exact hty.defeqDF (ih hf)
+
+/-- A dependently typed pointwise equality between two application spines.
+The recursive head is instantiated with the left argument, matching the
+result type chosen by `IsDefEq.appDF`; the right endpoint is transported to
+that same type by the equality stored at the current argument. -/
+inductive SpineDefEq (Γ : List SExpr) :
+    SExpr → List SExpr → List SExpr → SExpr → Prop where
+  | nil : SpineDefEq Γ A [] [] A
+  | cons :
+    IsDefEq Γ e e' A₁ →
+    SpineDefEq Γ (A₂.inst e) es es' B →
+    SpineDefEq Γ (.forallE A₁ A₂) (e :: es) (e' :: es') B
+  | conv :
+    IsDefEq Γ A A' (.sort u) →
+    SpineDefEq Γ A' es es' B →
+    SpineDefEq Γ A es es' B
+  | ret :
+    SpineDefEq Γ A es es' B →
+    IsDefEq Γ B B' (.sort u) →
+    SpineDefEq Γ A es es' B'
+
+/-- Concatenate pointwise spines while retaining successive result-type
+conversions as separate certificates. -/
+theorem SpineDefEq.append
+    (H₁ : SpineDefEq Γ A es es' B) (H₂ : SpineDefEq Γ B fs fs' C) :
+    SpineDefEq Γ A (es ++ fs) (es' ++ fs') C := by
+  induction H₁ with
+  | nil => simpa using H₂
+  | cons harg _ ih => exact .cons harg (ih H₂)
+  | conv hty _ ih => exact .conv hty (ih H₂)
+  | ret _ hret ih => exact ih (.conv hret H₂)
+
+/-- Extend a dependently typed pointwise spine by its final related
+argument.  The conversion at the old result exposes the next Pi; the new
+result is oriented at the left argument, exactly like `SpineDefEq.cons`. -/
+theorem SpineDefEq.snoc
+    (H : SpineDefEq Γ A es es' B)
+    (hB : IsDefEq Γ B (.forallE D C) (.sort u))
+    (he : IsDefEq Γ e e' D) :
+    SpineDefEq Γ A (es ++ [e]) (es' ++ [e']) (C.inst e) :=
+  H.append (.conv hB (.cons he .nil))
+
+/-- A typed pointwise spine applies congruently to related heads. -/
+theorem SpineDefEq.congr
+    (H : SpineDefEq Γ A es es' B) (hf : IsDefEq Γ f f' A) :
+    IsDefEq Γ (es.foldl (fun f a => f.app a) f)
+      (es'.foldl (fun f a => f.app a) f') B := by
+  induction H generalizing f f' with
+  | nil => exact hf
+  | cons he _ ih =>
+    simp only [List.foldl_cons]
+    exact ih (.appDF hf he)
+  | conv hty _ ih => exact ih (hty.defeqDF hf)
+  | ret _ hty ih => exact hty.defeqDF (ih hf)
+
+/-- Forget the right endpoint of a pointwise spine equality. -/
+theorem SpineDefEq.left
+    (H : SpineDefEq Γ A es es' B) : SpineWF Γ A es B := by
+  induction H with
+  | nil => exact .nil
+  | cons he _ ih => exact .cons (he.trans he.symm) ih
+  | conv hty _ ih => exact .conv hty ih
+  | ret _ hty ih => exact .ret ih hty
 
-axiom Params.extra_pat (Γ) : env.defeqs df → ls.length = df.uvars →
-  ∃ p r m1 m2 dfs, Pat p r ∧ p.MatchesS (.instL ls (.mk df.lhs)) m1 m2 ∧
-    (dfs : List _).map (·.2) = r.2.defeqsS m1 m2 ∧
-    (∀ a b A, (A, a, b) ∈ dfs → Γ ⊢ a ≡ b : A) ∧
-    .instL ls (.mk df.rhs) = r.1.applyS m1 m2
+/-- Reflexive pointwise equality underlying a well-typed spine. -/
+theorem SpineWF.toSpineDefEq
+    (H : SpineWF Γ A es B) : SpineDefEq Γ A es es B := by
+  induction H with
+  | nil => exact .nil
+  | cons he _ ih => exact .cons he ih
+  | conv hty _ ih => exact .conv hty ih
+  | ret _ hty ih => exact .ret ih hty
+
+/-- A spine indexed by the keys that selected its arguments.  Besides
+remembering order, the index fixes the exact domain type used at each
+dependent application.  This is the alignment that a plain `List SExpr`
+necessarily erases. -/
+inductive PathSpineWF (Γ : List SExpr) {α : Type}
+    (value type : α → SExpr) : SExpr → List α → SExpr → Prop where
+  | nil : PathSpineWF Γ value type A [] A
+  | cons :
+    IsDefEq Γ (type path) A₁ (.sort u) →
+    PathSpineWF Γ value type (A₂.inst (value path)) paths B →
+    PathSpineWF Γ value type (.forallE A₁ A₂) (path :: paths) B
+  | conv :
+    IsDefEq Γ A A' (.sort u) →
+    PathSpineWF Γ value type A' paths B →
+    PathSpineWF Γ value type A paths B
+  | ret :
+    PathSpineWF Γ value type A paths B →
+    IsDefEq Γ B B' (.sort u) →
+    PathSpineWF Γ value type A paths B'
+
+/-- Erase path indices after supplying the exact self-typing attached to
+each selected argument. -/
+theorem PathSpineWF.toSpineWF
+    (H : PathSpineWF Γ value type A paths B)
+    (htyped : ∀ path, IsDefEq Γ (value path) (value path) (type path)) :
+    SpineWF Γ A (paths.map value) B := by
+  induction H with
+  | nil => exact .nil
+  | cons hdom _ ih =>
+    simp only [List.map_cons]
+    exact .cons (hdom.defeqDF (htyped _)) ih
+  | conv hty _ ih => exact .conv hty ih
+  | ret _ hty ih => exact .ret ih hty
+
+/-- Retain the path-indexed dependent spine while replacing each selected
+capture by a related endpoint.  The recursive codomain is instantiated with
+the left capture, exactly as in `SpineDefEq.cons`; consequently no type
+uniqueness or reconstruction from the right spine is needed. -/
+theorem PathSpineWF.toSpineDefEq
+    (H : PathSpineWF Γ value type A paths B)
+    (hvalue : ∀ path, IsDefEq Γ (value path) (value' path) (type path)) :
+    SpineDefEq Γ A (paths.map value) (paths.map value') B := by
+  induction H with
+  | nil => exact .nil
+  | cons hdom _ ih =>
+    simp only [List.map_cons]
+    exact .cons (hdom.defeqDF (hvalue _)) ih
+  | conv hty _ ih => exact .conv hty ih
+  | ret _ hty ih => exact .ret ih hty
+
+/-- Concrete capture typings supplied to a generated reduction site.  Two
+sites can share the same `type` map while carrying endpoint-specific
+self-typings, which is precisely what dependent RHS congruence needs. -/
+structure _root_.Lean4Lean.Pattern.CaptureTyping
+    (Γ : List SExpr) {p : Pattern} (capture : p.Path → SExpr)
+    (type : p.Path → SExpr) : Prop where
+  typed : ∀ path, IsDefEq Γ (capture path) (capture path) (type path)
+
+/-- Typed syntax retained at one concrete iota site before its generated
+tower is selected.  Recursor arguments are in newest-first semantic order,
+so the typing spine reverses them and appends the major premise. -/
+structure _root_.Lean4Lean.Pattern.IotaTyping
+    (Γ : List SExpr) (rec ctor : Name)
+    (recLs ctorLs : List SLevel) (recArgs ctorArgs : List SExpr)
+    (majorTerm A : SExpr) where
+  recHeadType : SExpr
+  ctorHeadType : SExpr
+  ctorResultType : SExpr
+  majorType : SExpr
+  recHead : IsDefEq Γ (.const rec recLs) (.const rec recLs) recHeadType
+  recSpine : SpineWF Γ recHeadType
+    (recArgs.reverse ++ [majorTerm]) A
+  ctorHead : IsDefEq Γ (.const ctor ctorLs) (.const ctor ctorLs) ctorHeadType
+  ctorSpine : SpineWF Γ ctorHeadType ctorArgs.reverse ctorResultType
+  majorEq : IsDefEq Γ majorTerm
+    (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)) majorType
+
+/-- The concrete registered tower selected by one iota-pattern payload.
+This rule descriptor is independent of a particular match, so the two
+endpoints of a logical-relation comparison share the same tower and the same
+ordered capture paths by construction. -/
+structure _root_.Lean4Lean.Pattern.IotaRule
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    (r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check) where
+  pat : Params.Pat (RecursorIotaPattern rec major ctor arity) r
+  df : VDefEq
+  registered : Params.env.defeqs df
+  rhsClosed : df.rhs.Closed
+  capturePaths : List (RecursorIotaPattern rec major ctor arity).Path
+  rhsTower : r.1 = Pattern.RHS.appN (.fixed df.rhs rhsClosed)
+    (capturePaths.map fun path => .var path)
+
+/-- The syntax computed by a rule descriptor is its registered right tower
+applied to the descriptor's ordered concrete captures. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.rhsApply
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) (recLs : List SLevel)
+    (mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr) :
+    (rule.capturePaths.map mcap).foldl
+        (fun (f a : SExpr) => f.app a) (SExpr.mkInst recLs rule.df.rhs) =
+      r.1.applyS recLs mcap := by
+  rw [rule.rhsTower, Pattern.RHS.appN_applyS]
+  simp only [Pattern.RHS.applyS, List.foldl_map]
+
+/-- Evidence-rich generated reduction site.  Unlike the former direct
+`iotaAction` hook, this records the registered lambda tower, the exact typed
+capture application used to instantiate it, and the local beta collapse to
+the matched redex.  The final `Pattern.Action` is derived below. -/
+structure _root_.Lean4Lean.Pattern.IotaReductionSite
+    (Γ : List SExpr) {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    (r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check)
+    (rule : Pattern.IotaRule r)
+    (recLs ctorLs : List SLevel) (recArgs ctorArgs : List SExpr)
+    (majorTerm A : SExpr)
+    (mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+    (captureTyping : Pattern.CaptureTyping Γ mcap captureType) where
+  typing : Pattern.IotaTyping Γ rec ctor recLs ctorLs recArgs ctorArgs majorTerm A
+  matched : (RecursorIotaPattern rec major ctor arity).MatchesS
+    ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+      (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs))) recLs mcap
+  levelsLength : recLs.length = rule.df.uvars
+  captureSpine : PathSpineWF Γ mcap captureType
+    (SExpr.mkInst recLs rule.df.type) rule.capturePaths A
+  lhsCollapse : IsDefEq Γ
+    ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+      (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)))
+    ((rule.capturePaths.map mcap).foldl
+      (fun (f a : SExpr) => f.app a) (SExpr.mkInst recLs rule.df.lhs)) A
+  dfs : List (SExpr × SExpr × SExpr)
+  defeqs : dfs.map (·.2) = r.2.defeqsS recLs mcap
+  checked : ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Γ a b B
+
+/-- The finite evidence attached to one concrete pattern contraction.
+
+Pattern membership is only combinatorial. An `Action` additionally records
+the exact matched redex and captures, the finite list of checked equalities,
+and the local equality to the instantiated RHS. It deliberately does not
+contain endpoint typings: consumers of the action must retain those at the
+typing/reduction layer where they are known. -/
+structure _root_.Lean4Lean.Pattern.Action (Gamma : List SExpr) {p : Pattern}
+    (r : p.RHS × p.Check) (e : SExpr) (m1 : List SLevel)
+    (m2 : p.Path → SExpr) (A : SExpr) where
+  pat : Pat p r
+  matched : p.MatchesS e m1 m2
+  dfs : List (SExpr × SExpr × SExpr)
+  defeqs : dfs.map (·.2) = r.2.defeqsS m1 m2
+  checked : ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Gamma a b B
+  sound : IsDefEq Gamma e (r.1.applyS m1 m2) A
+
+/-- Semantic closure required to translate the live registered structure-eta
+rule.  This is a bridge obligation, not an axiom: L4L-16 constructs it from
+the checked `VEnv.WF` history before exposing sort inversion. -/
+def Params.StructureEtaSound : Prop :=
+  ∀ {rule : VStructEta} {levels : List VLevel} {Γ params : List VExpr}
+    {major : VExpr},
+    env.structEtas rule →
+    IsDefEq (Γ.map mk)
+      (mk (rule.rebuild levels params major))
+      (mk (rule.rebuild levels params major))
+      (mk (rule.structureType levels params)) →
+    IsDefEq (Γ.map mk) (mk major) (mk major)
+      (mk (rule.structureType levels params)) →
+    IsDefEq (Γ.map mk) (mk (rule.rebuild levels params major)) (mk major)
+      (mk (rule.structureType levels params))
+
+/-- Translate the main typing judgment into the semantically quotiented syntax. -/
+theorem IsDefEq.mkS (hstruct : Params.StructureEtaSound)
+    (H : Params.env.IsDefEq Params.univs Γ e₁ e₂ A) :
+    OnCtx Γ (fun _ A => A.LevelWF Params.univs) →
+    IsDefEq (Γ.map mk) (mk e₁) (mk e₂) (mk A) := by
+  intro hΓ
+  induction H using VEnv.IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
+  | bvar h => exact .bvar (SExpr.Lookup.mkS h)
+  | symm _ ih => exact .symm (ih hΓ)
+  | trans _ _ ih₁ ih₂ => exact .trans (ih₁ hΓ) (ih₂ hΓ)
+  | @sortDF l l' Γ hl hl' h =>
+    change IsDefEq _ (.sort (SLevel.mk _)) (.sort (SLevel.mk _)) (.sort (SLevel.mk _))
+    have hu := SLevel.mk_eq hl hl' h
+    have hus : SLevel.mk l.succ = (SLevel.mk l').succ := by rw [SLevel.mk_succ hl, hu]
+    rw [hu, hus]
+    exact .sort
+  | @constDF c ci ls ls' Γ h₁ h₂ h₃ h₄ h₅ =>
+    change IsDefEq _ (.const c (ls.map SLevel.mk)) (.const c (ls'.map SLevel.mk))
+      (mk (ci.type.instL ls))
+    rw [← SLevel.map_mk_eq h₂ h₃ h₅, ← mkInst_map_mk h₂]
+    exact IsDefEq.const (ls := ls.map SLevel.mk) h₁ (by simpa using h₄)
+  | appDF _ _ ihf iha => simpa only [mk, mk_instExpr] using IsDefEq.appDF (ihf hΓ) (iha hΓ)
+  | lamDF hA _ ihA ihb =>
+    have hAwf := (hA.levelWF hΓ).1
+    exact .lamDF (ihA hΓ) (ihb ⟨hΓ, hAwf⟩)
+  | forallEDF hA hb ihA ihb =>
+    have hAwf := (hA.levelWF hΓ).1
+    have hu := (hA.levelWF hΓ).2.2
+    have hv := (hb.levelWF ⟨hΓ, hAwf⟩).2.2
+    simpa only [mk, SLevel.mk_imax hu hv] using IsDefEq.forallEDF (ihA hΓ) (ihb ⟨hΓ, hAwf⟩)
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA hΓ) (ihe hΓ)
+  | beta _ he' ihe ihe' =>
+    have hAwf := (he'.levelWF hΓ).2.2
+    simpa only [mk, mk_instExpr] using IsDefEq.beta (ihe ⟨hΓ, hAwf⟩) (ihe' hΓ)
+  | eta _ ih => simpa only [mk, mk_lift] using IsDefEq.eta (ih hΓ)
+  | structEta hreg _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    exact hstruct hreg (ihRebuild hΓ) (ihMajor hΓ)
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel (ihp hΓ) (ihh hΓ) (ihh' hΓ)
+  | @extra df ls Γ h₁ h₂ h₃ =>
+    simpa only [mkInst_map_mk h₂] using
+      (IsDefEq.extra (Γ := Γ.map mk) (ls := ls.map SLevel.mk) h₁ (by simpa using h₃))
+  | nil => trivial
+  | cons => trivial
+
+/-- Translate a Theory application-spine certificate without erasing its
+per-argument typings.  This is the bridge needed by a live generated-iota
+reduction site; the endpoint-only translation is intentionally insufficient.
+-/
+theorem _root_.Lean4Lean.VEnv.SpineWF.mkS
+    (hstruct : Params.StructureEtaSound)
+    (H : Params.env.SpineWF Params.univs Γ A es B)
+    (hΓ : OnCtx Γ (fun _ A => A.LevelWF Params.univs)) :
+    SExpr.SpineWF (Γ.map SExpr.mk) (SExpr.mk A)
+      (es.map SExpr.mk) (SExpr.mk B) := by
+  exact VEnv.SpineWF.rec
+    (motive_1 := fun _ _ _ _ _ => True)
+    (motive_2 := fun Γ A es B _ =>
+      OnCtx Γ (fun _ A => A.LevelWF Params.univs) →
+      SExpr.SpineWF (Γ.map SExpr.mk) (SExpr.mk A)
+        (es.map SExpr.mk) (SExpr.mk B))
+    (bvar := by simp) (symm := by simp) (trans := by simp)
+    (sortDF := by simp) (constDF := by simp) (appDF := by simp)
+    (lamDF := by simp) (forallEDF := by simp) (defeqDF := by simp)
+    (beta := by simp) (eta := by simp) (structEta := by simp)
+    (proofIrrel := by simp) (extra := by simp)
+    (nil := fun {_Γ _A} _hΓ => .nil)
+    (cons := fun {_Γ _e _A₁ _es _B _A₂} he _ _ ih hΓ => by
+      exact .cons (SExpr.IsDefEq.mkS hstruct he hΓ) (by
+        simpa only [SExpr.mk_instExpr] using ih hΓ))
+    H hΓ
 
 def CtorBundle.IsCtor (c : Name) : Prop :=
   ∃ cl, Params.classify c = some cl ∧ cl matches .ctor .. | .etaCtor ..
@@ -644,20 +1905,25 @@ local notation:65 (priority := high) Γ " ⊢ " e1 " ≡ " e2 " : " A:36 => IsDe
 inductive IsDefEqStrong : List SExpr → SExpr → SExpr → SExpr → Prop where
   | bvar : Lookup Γ i A → Γ ⊢ A : .sort u → Γ ⊢ .bvar i : A
   | symm : Γ ⊢ e ≡ e' : A → Γ ⊢ e' ≡ e : A
-  | trans : Γ ⊢ A : .sort u → Γ ⊢ e₁ ≡ e₂ : A → Γ ⊢ e₂ ≡ e₃ : A → Γ ⊢ e₁ ≡ e₃ : A
-  /-- Heterogeneous transitivity: middle term may be at a different sort. -/
-  | trans' : Γ ⊢ A ≡ B : .sort u → Γ ⊢ B ≡ C : .sort v → Γ ⊢ A ≡ C : .sort u
+  | trans : Γ ⊢ e₁ ≡ e₂ : A → Γ ⊢ e₂ ≡ e₃ : A → Γ ⊢ e₁ ≡ e₃ : A
   | sort : Γ ⊢ .sort l : .sort (.succ l)
   | const : env.constants c = some ci → ls.length = ci.uvars →
-    Γ ⊢ (SExpr.mk ci.type).instL ls : .sort u →
+    Γ ⊢ SExpr.mkInst ls ci.type : .sort u →
     (F : ∀ cl, CtorBundle c cl) →
-    (∀ cl, Γ ⊢ (SExpr.mk ci.type).instL ls ≡ (F cl).rhs ls : .sort (F cl).u) →
-    Γ ⊢ .const c ls : (SExpr.mk ci.type).instL ls
-  | appDF : Γ ⊢ A : .sort u →
+    (∀ cl, Γ ⊢ SExpr.mkInst ls ci.type ≡ (F cl).rhs ls : .sort (F cl).u) →
+    -- Definition bodies are stored in the direction used by semantic
+    -- recursion: the body is the left endpoint, so its adequacy hypothesis can
+    -- consume the strictly smaller `R`-child exposed by `LE_Interp.Const.pat`.
+    -- The ordinary constant equality remains available by symmetry.
+    (∀ {r : (Pattern.const c).RHS × (Pattern.const c).Check}, Pat (.const c) r →
+      Γ ⊢ r.1.applyS ls Empty.elim ≡ .const c ls : SExpr.mkInst ls ci.type) →
+    Γ ⊢ .const c ls : SExpr.mkInst ls ci.type
+  | appDF : Γ ⊢ A : .sort u → A::Γ ⊢ B : .sort v →
     Γ ⊢ f ≡ f' : .forallE A B → Γ ⊢ a ≡ a' : A →
     Γ ⊢ B.inst a ≡ B.inst a' : .sort v →
     Γ ⊢ .app f a ≡ .app f' a' : B.inst a
   | lamDF : Γ ⊢ A ≡ A' : .sort u → A::Γ ⊢ B : .sort v →
+    A'::Γ ⊢ B : .sort v →
     A::Γ ⊢ body ≡ body' : B → A'::Γ ⊢ body ≡ body' : B →
     Γ ⊢ .lam A body ≡ .lam A' body' : .forallE A B
   | forallEDF : Γ ⊢ A ≡ A' : .sort u →
@@ -670,22 +1936,419 @@ inductive IsDefEqStrong : List SExpr → SExpr → SExpr → SExpr → Prop wher
   | eta : Γ ⊢ e : .forallE A B → Γ ⊢ .lam A (.app e.lift (.bvar 0)) : .forallE A B →
     Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B
   | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ h' : p
-  | extra : env.defeqs df → ls.length = df.uvars →
-    Γ ⊢ .instL ls (.mk df.lhs) : .instL ls (.mk df.type) →
-    Γ ⊢ .instL ls (.mk df.rhs) : .instL ls (.mk df.type) →
-    Γ ⊢ .instL ls (.mk df.lhs) ≡ .instL ls (.mk df.rhs) : .instL ls (.mk df.type)
+  /-- A zero-arity definition contraction without the recursive constant-
+  typing knot.  The local action supplies the ordinary equality, the RHS is
+  strongly typed, and the constant metadata is exactly the non-definition
+  fragment needed to type the left endpoint. -/
+  | defn {r : (Pattern.const c).RHS × (Pattern.const c).Check} :
+    env.constants c = some ci → ls.length = ci.uvars →
+    Γ ⊢ SExpr.mkInst ls ci.type : .sort u →
+    (F : ∀ cl, CtorBundle c cl) →
+    (∀ cl, Γ ⊢ SExpr.mkInst ls ci.type ≡ (F cl).rhs ls : .sort (F cl).u) →
+    (action : Pattern.Action Γ r (.const c ls) ls Empty.elim
+      (SExpr.mkInst ls ci.type)) →
+    Γ ⊢ r.1.applyS ls Empty.elim : SExpr.mkInst ls ci.type →
+    Γ ⊢ .const c ls ≡ r.1.applyS ls Empty.elim : SExpr.mkInst ls ci.type
+  /-- A local, proof-carrying extension contraction.  Unlike a registered
+  raw equation, this constructor can be interpreted operationally: it names
+  the concrete matched redex, carries its successful checks and exact local
+  equality, and retains strong typings for both endpoints. -/
+  | extra : (action : Pattern.Action Γ r e m1 m2 A) →
+    Γ ⊢ e : A → Γ ⊢ r.1.applyS m1 m2 : A →
+    Γ ⊢ e ≡ r.1.applyS m1 m2 : A
 end
 
-theorem IsDefEq.strong : Γ ⊢ e1 ≡ e2 : A → IsDefEqStrong Γ e1 e2 A := sorry
-theorem IsDefEqStrong.defeq : IsDefEqStrong Γ e1 e2 A → Γ ⊢ e1 ≡ e2 : A := sorry
-
-theorem _root_.Lean4Lean.Params.ctor_ty
-    (hcl1 : Params.classify c = some cl) (hcl2 : cl matches .ctor .. | .etaCtor ..)
-    (hci : env.constants c = some ci) (h_len : ls.length = ci.uvars) :
-    ∃ (I : Name) (Ts args : List SExpr) (u : SLevel),
-      Ts.length = cl.arity ∧ Params.classify I = some (.indTy args.length) ∧ u ≠ .zero ∧
-      Γ ⊢ (SExpr.mk ci.type).instL ls ≡
-        Ts.foldr .forallE (args.foldr (fun A acc => acc.app A) (.const I ls)) : .sort u := sorry
+/-! The semantic bridge packages only environment-specific facts.  Its fields
+are propositions carried by a concrete value; the public L4L-16 theorem
+constructs that value from `VEnv.WF`, so none of these are trusted axioms. -/
+class Params.Semantic [Params] where
+  structureEta :
+    ∀ {rule : VStructEta} {levels : List VLevel} {Γ params : List VExpr}
+      {major : VExpr},
+      env.structEtas rule →
+      IsDefEqStrong (Γ.map mk)
+        (mk (rule.rebuild levels params major))
+        (mk (rule.rebuild levels params major))
+        (mk (rule.structureType levels params)) →
+      IsDefEqStrong (Γ.map mk) (mk major) (mk major)
+        (mk (rule.structureType levels params)) →
+      IsDefEqStrong (Γ.map mk) (mk (rule.rebuild levels params major))
+        (mk major) (mk (rule.structureType levels params))
+  ctor :
+    ∀ {c : Name} {ci : VConstant} {ls : List SLevel} {Γ : List SExpr},
+      env.constants c = some ci → ls.length = ci.uvars →
+      ∀ cl : CtorBundle.IsCtor c,
+        {F : CtorBundle c cl //
+          IsDefEqStrong Γ (SExpr.mkInst ls ci.type) (F.rhs ls) (.sort F.u)}
+  /-- Zero-arity patterns are definition rules.  The payload is a closed
+  fixed expression and the bridge supplies its evidence-rich unfolding in
+  every context.  This is proved from the declaration history; pattern
+  membership by itself provides none of these facts. -/
+  defn :
+    ∀ {c : Name} {r : (Pattern.const c).RHS × (Pattern.const c).Check},
+      Pat (.const c) r →
+      ∃ (value : VExpr) (closed : value.Closed),
+        r = (.fixed value closed, .true) ∧
+        ∀ {ci : VConstant} {ls : List SLevel} {Γ : List SExpr},
+          env.constants c = some ci → ls.length = ci.uvars →
+          IsDefEqStrong Γ (.const c ls) (SExpr.mkInst ls value)
+            (SExpr.mkInst ls ci.type)
+  /-- Recover the one registered tower and ordered capture inventory selected
+  by an iota payload.  This descriptor is match-independent and is therefore
+  shared by both endpoints of a semantic comparison. -/
+  iotaRule :
+    ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check},
+      Pat (RecursorIotaPattern rec major ctor arity) r →
+      Pattern.IotaRule r
+  /-- Construct the evidence-rich site for a generated iota contraction.
+  This field cannot return the contraction itself: it must expose the
+  registered tower, typed capture application, and beta collapse, while the
+  caller supplies the exact typed recursor and constructor spines (including
+  the constructor levels recovered from the match).  `IotaReductionSite.action`
+  derives the finite local contraction generically from this certificate. -/
+  iotaSite :
+    ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      {Γ : List SExpr} {A majorTerm : SExpr} {recLs ctorLs : List SLevel}
+      {recArgs ctorArgs : List SExpr}
+      {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr},
+      (rule : Pattern.IotaRule r) →
+      (captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr) →
+      (captureTyping : Pattern.CaptureTyping Γ mcap captureType) →
+      /- Capture witnesses may arrive at an existentially selected common
+      type.  Reified context validity is the finite evidence needed to align
+      those types with the concrete generated telescope; without it this
+      data-valued field is not constructible for an arbitrary `captureType`.
+      The adequacy caller obtains this premise from `Ctx.WF.reify`. -/
+      OnCtx (Γ.map SExpr.reify) (env.IsType univs) →
+      (typing : Pattern.IotaTyping Γ rec ctor recLs ctorLs
+        recArgs ctorArgs majorTerm A) →
+      (RecursorIotaPattern rec major ctor arity).MatchesS
+        ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+          (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)))
+        recLs mcap →
+      IsDefEq Γ
+        ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+          (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)))
+        ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+          (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs))) A →
+      (∃ u, IsDefEq Γ A A (.sort u)) →
+      Pattern.IotaReductionSite Γ r rule recLs ctorLs recArgs ctorArgs
+        majorTerm A mcap captureType captureTyping
+  /-- Expand a registered raw equation into structural strong equality whose
+  only extension leaves are the proof-carrying local contractions above.
+  Generated iota and quotient towers are therefore exposed under their
+  lambdas instead of being falsely matched at the closed tower. -/
+  registered :
+    ∀ {df : VDefEq} {ls : List SLevel} {Γ : List SExpr},
+      env.defeqs df → ls.length = df.uvars →
+      IsDefEqStrong Γ (.mkInst ls df.lhs) (.mkInst ls df.lhs) (.mkInst ls df.type) →
+      IsDefEqStrong Γ (.mkInst ls df.rhs) (.mkInst ls df.rhs) (.mkInst ls df.type) →
+      IsDefEqStrong Γ (.mkInst ls df.lhs) (.mkInst ls df.rhs) (.mkInst ls df.type)
+
+/-- A generated reduction-site certificate determines its finite local
+contraction.  Soundness is assembled from the local beta collapse and the
+registered tower equation applied along the retained capture spine; it is
+not supplied by pattern membership. -/
+def _root_.Lean4Lean.Pattern.IotaReductionSite.action
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r}
+    {Γ : List SExpr} {recLs ctorLs : List SLevel}
+    {recArgs ctorArgs : List SExpr} {majorTerm A : SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {captureTyping : Pattern.CaptureTyping Γ mcap captureType}
+    (site : Pattern.IotaReductionSite Γ r rule recLs ctorLs recArgs ctorArgs
+      majorTerm A mcap captureType captureTyping) :
+    Pattern.Action Γ r
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const ctor ctorLs)))
+      recLs mcap A := by
+  have hregistered : IsDefEq Γ
+      (SExpr.mkInst recLs rule.df.lhs) (SExpr.mkInst recLs rule.df.rhs)
+      (SExpr.mkInst recLs rule.df.type) :=
+    .extra rule.registered site.levelsLength
+  have hspine := site.captureSpine.toSpineWF captureTyping.typed
+  have happlied := hspine.congr hregistered
+  have hsound := site.lhsCollapse.trans happlied
+  rw [rule.rhsApply recLs mcap] at hsound
+  exact {
+    pat := rule.pat
+    matched := site.matched
+    dfs := site.dfs
+    defeqs := site.defeqs
+    checked := site.checked
+    sound := hsound }
+
+/-- Translate Theory's evidence-rich judgment directly.  Unlike the former
+admitted `SExpr.IsDefEq.strong`, this theorem never tries to recover missing
+typing premises from a raw SExpr derivation. -/
+theorem _root_.Lean4Lean.VEnv.IsDefEqStrong.mkS [Params.Semantic]
+    (H : Params.env.IsDefEqStrong Params.univs Γ e₁ e₂ A) :
+    IsDefEqStrong (Γ.map mk) (mk e₁) (mk e₂) (mk A) := by
+  induction H with
+  | bvar h _ _ ihA => exact .bvar (SExpr.Lookup.mkS h) ihA
+  | symm _ ih => exact ih.symm
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sortDF l l' Γ hl hl' heq =>
+    have hll := SLevel.mk_eq hl hl' heq
+    have hsucc : SLevel.mk l.succ = (SLevel.mk l').succ := by
+      rw [SLevel.mk_succ hl, hll]
+    simpa only [mk, hll, hsucc] using (IsDefEqStrong.sort (Γ := Γ.map mk)
+      (l := SLevel.mk l'))
+  | @constDF c ci ls ls' u Γ hci hls hls' hlen hlevels _ _ _ ihGlobal ihLocal =>
+    have hmap := SLevel.map_mk_eq hls hls' hlevels
+    change IsDefEqStrong (Γ.map mk)
+      (.const c (ls.map SLevel.mk)) (.const c (ls'.map SLevel.mk))
+      (mk (ci.type.instL ls))
+    rw [← hmap]
+    have ihLocal' := ihLocal
+    rw [← mkInst_map_mk hls, ← mkInst_map_mk hls', ← hmap] at ihLocal'
+    have htype : IsDefEqStrong (Γ.map mk)
+        (SExpr.mkInst (ls.map SLevel.mk) ci.type)
+        (SExpr.mkInst (ls.map SLevel.mk) ci.type)
+        (.sort (SLevel.mk u)) := by
+      simpa only [mk] using ihLocal'
+    let F : ∀ cl, CtorBundle c cl := fun cl =>
+      (Params.Semantic.ctor (ls := ls.map SLevel.mk) (Γ := Γ.map mk)
+        hci (by simpa using hlen) cl).1
+    have hF : ∀ cl, IsDefEqStrong (Γ.map mk)
+        (SExpr.mkInst (ls.map SLevel.mk) ci.type) ((F cl).rhs (ls.map SLevel.mk))
+        (.sort (F cl).u) := by
+      intro cl
+      exact (Params.Semantic.ctor (ls := ls.map SLevel.mk) (Γ := Γ.map mk)
+        hci (by simpa using hlen) cl).2
+    have hDef : ∀ {r : (Pattern.const c).RHS × (Pattern.const c).Check},
+        Params.Pat (.const c) r →
+        IsDefEqStrong (Γ.map mk) (r.1.applyS (ls.map SLevel.mk) Empty.elim)
+          (.const c (ls.map SLevel.mk))
+          (SExpr.mkInst (ls.map SLevel.mk) ci.type) := by
+      intro r hpat
+      obtain ⟨value, closed, hr, hdef⟩ := Params.Semantic.defn hpat
+      subst r
+      simpa only [Pattern.RHS.applyS] using
+        (hdef hci (by simpa using hlen) : IsDefEqStrong (Γ.map mk)
+          (.const c (ls.map SLevel.mk)) (SExpr.mkInst (ls.map SLevel.mk) value)
+          (SExpr.mkInst (ls.map SLevel.mk) ci.type)).symm
+    simpa only [mkInst_map_mk hls] using
+      (IsDefEqStrong.const hci (by simpa using hlen) htype F hF hDef)
+  | appDF _ _ _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    have ihResult' := ihResult
+    simp only [mk, mk_instExpr] at ihResult'
+    simpa only [List.map_cons, mk, mk_instExpr] using
+      IsDefEqStrong.appDF ihA ihCod ihf iha ihResult'
+  | lamDF _ _ _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    exact .lamDF ihA ihB ihB' ihBody ihBody'
+  | forallEDF hu hv _ _ _ ihA ihBody ihBody' =>
+    simpa only [mk, SLevel.mk_imax hu hv] using
+      IsDefEqStrong.forallEDF ihA ihBody ihBody'
+  | defeqDF _ _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ _ _ _ _ _ _ ihA ihB ihBody ihArg ihResult ihInst =>
+    have ihResult' := ihResult
+    have ihInst' := ihInst
+    simp only [mk, mk_instExpr] at ihResult' ihInst'
+    have hlam := IsDefEqStrong.lamDF ihA ihB ihB ihBody ihBody
+    have happ := IsDefEqStrong.appDF ihA ihB hlam ihArg ihResult'
+    simpa only [mk, mk_instExpr] using
+      IsDefEqStrong.beta ihBody ihArg happ ihInst'
+  | @eta Γ A u B v e _ _ _ _ _ _ _ _
+      ihA ihB ihBWeak ihe iheWeak ihAWeak =>
+    have ihAWeak' : IsDefEqStrong (mk A :: Γ.map mk)
+        (mk A).lift (mk A).lift (.sort (SLevel.mk u)) := by
+      simpa only [List.map_cons, mk, mk_lift] using ihAWeak
+    have iheWeak' : IsDefEqStrong (mk A :: Γ.map mk)
+        (mk e).lift (mk e).lift
+        (.forallE (mk A).lift (mk (B.liftN 1 1))) := by
+      simpa only [List.map_cons, mk, mk_lift] using iheWeak
+    have ihBWeak' : IsDefEqStrong ((mk A).lift :: mk A :: Γ.map mk)
+        (mk (B.liftN 1 1)) (mk (B.liftN 1 1))
+        (.sort (SLevel.mk v)) := by
+      simpa only [List.map_cons, mk, mk_lift] using ihBWeak
+    have hbvar : IsDefEqStrong (mk A :: Γ.map mk)
+        (.bvar 0) (.bvar 0) (mk A).lift :=
+      .bvar .zero ihAWeak'
+    have hresult : (mk (B.liftN 1 1)).inst (.bvar 0) = mk B := by
+      change (mk (B.liftN 1 1)).inst (mk (.bvar 0)) = mk B
+      rw [← mk_instExpr]
+      exact congrArg mk (VExpr.instN_bvar0 B 0)
+    have happ : IsDefEqStrong (mk A :: Γ.map mk)
+        (.app (mk e).lift (.bvar 0)) (.app (mk e).lift (.bvar 0)) (mk B) := by
+      rw [← hresult]
+      exact IsDefEqStrong.appDF ihAWeak' ihBWeak' iheWeak' hbvar (hresult ▸ ihB)
+    have hlam := IsDefEqStrong.lamDF ihA ihB ihB happ happ
+    simpa only [mk, mk_lift] using IsDefEqStrong.eta ihe hlam
+  | structEta hreg _ _ _ _ _ _ _ _ ihType ihMajor ihRebuild =>
+    exact Params.Semantic.structureEta hreg ihRebuild ihMajor
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @extra df ls u Γ hreg hlevels hlen _ _ _ _ _ _ _ _ _ ihLhs ihRhs =>
+    have ihLhs' := ihLhs
+    have ihRhs' := ihRhs
+    rw [← mkInst_map_mk hlevels, ← mkInst_map_mk hlevels] at ihLhs' ihRhs'
+    simpa only [mkInst_map_mk hlevels] using
+      (Params.Semantic.registered (Γ := Γ.map mk) (ls := ls.map SLevel.mk)
+        hreg (by simpa using hlen) ihLhs' ihRhs')
+
+/-- Reify semantic universe levels to instantiate a closed Theory typing,
+then translate its evidence-rich strengthening back to any SExpr context.
+This is the fixed-head typing input needed by semantic `R`-recursion: it is
+derived from `Params.henv`, not added to `Params.Semantic` as an oracle. -/
+theorem Params.Semantic.closedHasTypeStrong
+    [Params.Semantic]
+    {U : Nat} {e A : VExpr} {ls : List SLevel} {Γ : List SExpr}
+    (H : Params.env.HasType U [] e A) :
+    IsDefEqStrong Γ (SExpr.mkInst ls e) (SExpr.mkInst ls e)
+      (SExpr.mkInst ls A) := by
+  let vls := ls.map SLevel.reify
+  have hlevels : ∀ l ∈ vls, l.WF Params.univs := by
+    intro l hl
+    simp only [vls, List.mem_map] at hl
+    obtain ⟨sl, _, rfl⟩ := hl
+    exact SLevel.reify_wf sl
+  have hStrong :=
+    ((H.strong Params.henv (by trivial)).instL hlevels).weak0
+      Params.henv (Γ := Γ.map SExpr.reify)
+  have hS := hStrong.mkS
+  have hvls : vls.map SLevel.mk = ls := by
+    change (ls.map SLevel.reify).map SLevel.mk = ls
+    rw [List.map_map]
+    exact List.map_id''' ls fun sl _ => SLevel.mk_reify sl
+  have hctx : (Γ.map SExpr.reify).map SExpr.mk = Γ := by
+    rw [List.map_map]
+    exact List.map_id''' Γ fun term _ => SExpr.mk_reify term
+  have hmkinst (term : VExpr) :
+      SExpr.mkInst ls term = SExpr.mk (term.instL vls) := by
+    rw [← hvls]
+    exact SExpr.mkInst_map_mk hlevels
+  simpa only [hctx, hmkinst] using hS
+
+/-- A registered equation's right tower has an evidence-rich self-typing at
+every semantic level instantiation. -/
+theorem Params.Semantic.registeredRhsStrong
+    [Params.Semantic]
+    {df : VDefEq} {ls : List SLevel} {Γ : List SExpr}
+    (hreg : Params.env.defeqs df) :
+    IsDefEqStrong Γ (SExpr.mkInst ls df.rhs) (SExpr.mkInst ls df.rhs)
+      (SExpr.mkInst ls df.type) :=
+  Params.Semantic.closedHasTypeStrong (Params.henv.defEqWF hreg).2
+
+/-- The fixed head selected by an iota descriptor is strongly self-typed.
+This is the syntactic half of the repaired `IotaRHSDefEq` contract; its
+logical adequacy is supplied by the surrounding semantic `R` recursion. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.rhsStrong
+    [Params.Semantic]
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) (ls : List SLevel) :
+    IsDefEqStrong Γ (SExpr.mkInst ls rule.df.rhs)
+      (SExpr.mkInst ls rule.df.rhs) (SExpr.mkInst ls rule.df.type) :=
+  Params.Semantic.registeredRhsStrong rule.registered
+
+theorem IsDefEqStrong.defeq : IsDefEqStrong Γ e1 e2 A → Γ ⊢ e1 ≡ e2 : A := by
+  intro H
+  induction H with
+  | bvar h _ _ => exact .bvar h
+  | symm _ ih => exact ih.symm
+  | trans _ _ ih₁ ih₂ => exact ih₁.trans ih₂
+  | sort => exact .sort
+  | const hreg hlen _ _ _ => exact .const hreg hlen
+  | appDF _ _ _ _ _ _ _ ihf iha _ => exact .appDF ihf iha
+  | lamDF _ _ _ _ _ ihA _ _ ihBody _ => exact .lamDF ihA ihBody
+  | forallEDF _ _ _ ihA ihBody _ => exact .forallEDF ihA ihBody
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ _ _ ihBody ihArg _ _ => exact .beta ihBody ihArg
+  | eta _ _ ihe _ => exact .eta ihe
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | defn _ _ _ _ _ action => exact action.sound
+  | extra action _ _ _ _ => exact action.sound
+
+/-- Both endpoints of an evidence-rich equality retain evidence-rich
+self-typings at its declared type.  Unlike the corresponding weak fact,
+this is just homogeneous composition and therefore does not need type
+uniqueness. -/
+theorem IsDefEqStrong.hasType
+    (H : IsDefEqStrong Γ e₁ e₂ A) :
+    IsDefEqStrong Γ e₁ e₁ A ∧ IsDefEqStrong Γ e₂ e₂ A :=
+  ⟨H.trans H.symm, H.symm.trans H⟩
+
+/-- If either endpoint of an evidence-rich equality is syntactically a Pi,
+recover evidence-rich validity of its domain and codomain.  All extension
+leaves of `IsDefEqStrong` carry their endpoint typings, so this eliminator is
+structural; in particular it does not appeal to weak type uniqueness or
+Church--Rosser. -/
+theorem IsDefEqStrong.forallE_inv'
+    (H : IsDefEqStrong Γ e₁ e₂ V)
+    (eq : e₁ = .forallE A B ∨ e₂ = .forallE A B) :
+    (∃ u, IsDefEqStrong Γ A A (.sort u)) ∧
+      ∃ v, IsDefEqStrong (A :: Γ) B B (.sort v) := by
+  induction H generalizing A B with
+  | bvar => nomatch eq
+  | symm _ ih => exact ih eq.symm
+  | trans _ _ ih₁ ih₂ =>
+    obtain eq | eq := eq
+    · exact ih₁ (.inl eq)
+    · exact ih₂ (.inr eq)
+  | sort => nomatch eq
+  | const => nomatch eq
+  | appDF => nomatch eq
+  | lamDF => nomatch eq
+  | forallEDF hA hBody hBody' _ _ _ =>
+    obtain ⟨⟨⟩⟩ | ⟨⟨⟩⟩ := eq
+    · exact ⟨⟨_, hA.hasType.1⟩, _, hBody.hasType.1⟩
+    · exact ⟨⟨_, hA.hasType.2⟩, _, hBody'.hasType.2⟩
+  | defeqDF _ _ _ ih => exact ih eq
+  | beta _ _ _ _ _ _ _ ihInst =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihInst (.inl eq)
+  | eta _ _ ihTerm _ =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihTerm (.inl eq)
+  | proofIrrel _ _ _ ihProp ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+  | defn _ _ _ _ _ _ _ _ _ ihRhs =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihRhs (.inl eq)
+  | extra _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+
+/-- The declared type of every evidence-rich equality is itself an
+evidence-rich type.  The extra premises retained by application, lambda,
+beta, eta, and local extension constructors make this a direct structural
+proof. -/
+theorem IsDefEqStrong.isType
+    (H : IsDefEqStrong Γ e₁ e₂ A) :
+    ∃ u, IsDefEqStrong Γ A A (.sort u) := by
+  induction H with
+  | bvar _ hA _ => exact ⟨_, hA⟩
+  | symm _ ih => exact ih
+  | trans _ _ ih _ => exact ih
+  | sort => exact ⟨_, .sort⟩
+  | const _ _ hTy _ _ _ _ _ _ => exact ⟨_, hTy⟩
+  | appDF _ _ _ _ hResult _ _ _ _ _ =>
+    exact ⟨_, hResult.hasType.1⟩
+  | lamDF hA hBody _ _ _ _ _ _ _ _ =>
+    have hAA := hA.hasType.1
+    have hBB := hBody.hasType.1
+    exact ⟨_, .forallEDF hAA hBB hBB⟩
+  | forallEDF => exact ⟨_, .sort⟩
+  | defeqDF hType _ _ _ => exact ⟨_, hType.hasType.2⟩
+  | beta _ _ _ _ _ _ _ ihInst => exact ihInst
+  | eta _ _ ihTerm _ => exact ihTerm
+  | proofIrrel hProp _ _ _ _ _ => exact ⟨_, hProp⟩
+  | defn _ _ hTy => exact ⟨_, hTy⟩
+  | extra _ _ _ ihLeft _ => exact ihLeft
 
 theorem IsDefEq.hasType (H : Γ ⊢ e1 ≡ e2 : A) :
     Γ ⊢ e1 ≡ e1 : A ∧ Γ ⊢ e2 ≡ e2 : A := ⟨H.trans H.symm, H.symm.trans H⟩
@@ -703,8 +2366,8 @@ inductive HasTypeStratifiedS : List SExpr → SExpr → SExpr → Bool → Nat 
   | const :
     env.constants c = some ci →
     ls.length = ci.uvars →
-    Γ ⊢ (mk ci.type).instL ls : .sort u !! n →
-    Γ ⊢ .const c ls :! (mk ci.type).instL ls !! n+1
+    Γ ⊢ SExpr.mkInst ls ci.type : .sort u !! n →
+    Γ ⊢ .const c ls :! SExpr.mkInst ls ci.type !! n+1
   | app :
     Γ ⊢ A : .sort u !! n →
     A::Γ ⊢ B : .sort v !! n →
@@ -723,7 +2386,7 @@ inductive HasTypeStratifiedS : List SExpr → SExpr → SExpr → Bool → Nat 
     A::Γ ⊢ body : .sort v !! n →
     Γ ⊢ .forallE A body :! .sort (.imax u v) !! n+1
   | base : Γ ⊢ e :! A !! n → Γ ⊢ e : A !! n
-  | defeq : Γ ⊢ A ≡ B : .sort u →
+  | defeq : IsDefEqStrong Γ A B (.sort u) →
     Γ ⊢ A : .sort u !! n → Γ ⊢ B : .sort u !! n →
     Γ ⊢ e : A !! n → Γ ⊢ e : B !! n+1
 end
@@ -731,17 +2394,774 @@ end
 scoped notation:65 Γ " ⊢ " e " : " A:36 " !! " n:36 => HasTypeStratifiedS Γ e A true n
 scoped notation:65 Γ " ⊢ " e " :! " A:36 " !! " n:36 => HasTypeStratifiedS Γ e A false n
 
+theorem HasTypeStratifiedS.mono (le : m ≤ n)
+    (H : HasTypeStratifiedS Γ e A b m) : HasTypeStratifiedS Γ e A b n := by
+  induction H generalizing n with
+  | bvar h _ ih =>
+    let n + 1 := n
+    exact .bvar h (ih (Nat.le_of_succ_le_succ le))
+  | sort' => exact .sort'
+  | const hreg hlen _ ih =>
+    let n + 1 := n
+    exact .const hreg hlen (ih (Nat.le_of_succ_le_succ le))
+  | app _ _ _ _ _ ihA ihB ihf iha ihR =>
+    let n + 1 := n
+    replace le := Nat.le_of_succ_le_succ le
+    exact .app (ihA le) (ihB le) (ihf le) (iha le) (ihR le)
+  | lam _ _ _ _ ihA ihB ihBody ihPi =>
+    let n + 1 := n
+    replace le := Nat.le_of_succ_le_succ le
+    exact .lam (ihA le) (ihB le) (ihBody le) (ihPi le)
+  | forallE _ _ ihA ihBody =>
+    let n + 1 := n
+    replace le := Nat.le_of_succ_le_succ le
+    exact .forallE (ihA le) (ihBody le)
+  | base _ ih => exact .base (ih le)
+  | defeq h _ _ _ ihA ihB ihe =>
+    let n + 1 := n
+    replace le := Nat.le_of_succ_le_succ le
+    exact .defeq h (ihA le) (ihB le) (ihe le)
+
+/-! ### A δ-rank refinement of stratified typing
+
+`VEnv.WF` permits mutually recursive definition cycles, so termination of
+the semantic constant evaluator cannot be recovered from declaration order.
+The rank below is therefore explicit instance data.  The judgment refines
+`HasTypeStratifiedS` without changing its depth index: only the `const` rule
+records that the referenced declaration is available at the current rank.
+-/
+
+/-- Stratified typing with an additional upper bound on the δ-rank of every
+constant used by the derivation. -/
+inductive HasTypeStratifiedR (rank : Name → Nat) :
+    List SExpr → SExpr → SExpr → Bool → Nat → Nat → Prop where
+  | bvar {n r : Nat} :
+    Lookup Γ i A →
+    HasTypeStratifiedR rank Γ A (.sort u) true n r →
+    HasTypeStratifiedR rank Γ (.bvar i) A false (n + 1) r
+  | sort' {n r : Nat} :
+    HasTypeStratifiedR rank Γ (.sort l) (.sort (.succ l)) false n r
+  | const {n r : Nat} :
+    env.constants c = some ci →
+    ls.length = ci.uvars →
+    rank c ≤ r →
+    HasTypeStratifiedR rank Γ (SExpr.mkInst ls ci.type) (.sort u) true n r →
+    HasTypeStratifiedR rank Γ (.const c ls)
+      (SExpr.mkInst ls ci.type) false (n + 1) r
+  | app {n r : Nat} :
+    HasTypeStratifiedR rank Γ A (.sort u) true n r →
+    HasTypeStratifiedR rank (A :: Γ) B (.sort v) true n r →
+    HasTypeStratifiedR rank Γ f (.forallE A B) true n r →
+    HasTypeStratifiedR rank Γ a A true n r →
+    HasTypeStratifiedR rank Γ (B.inst a) (.sort v) true n r →
+    HasTypeStratifiedR rank Γ (.app f a) (B.inst a) false (n + 1) r
+  | lam {n r : Nat} :
+    HasTypeStratifiedR rank Γ A (.sort u) true n r →
+    HasTypeStratifiedR rank (A :: Γ) B (.sort v) true n r →
+    HasTypeStratifiedR rank (A :: Γ) body B true n r →
+    HasTypeStratifiedR rank Γ (.forallE A B) (.sort (.imax u v)) true n r →
+    HasTypeStratifiedR rank Γ (.lam A body) (.forallE A B) false (n + 1) r
+  | forallE {n r : Nat} :
+    HasTypeStratifiedR rank Γ A (.sort u) true n r →
+    HasTypeStratifiedR rank (A :: Γ) body (.sort v) true n r →
+    HasTypeStratifiedR rank Γ (.forallE A body)
+      (.sort (.imax u v)) false (n + 1) r
+  | base :
+    HasTypeStratifiedR rank Γ e A false n r →
+    HasTypeStratifiedR rank Γ e A true n r
+  | defeq :
+    IsDefEqStrong Γ A B (.sort u) →
+    HasTypeStratifiedR rank Γ A (.sort u) true n r →
+    HasTypeStratifiedR rank Γ B (.sort u) true n r →
+    HasTypeStratifiedR rank Γ e A true n r →
+    HasTypeStratifiedR rank Γ e B true (n + 1) r
+
+/-- Forgetting the δ-rank recovers the ordinary stratified judgment. -/
+theorem HasTypeStratifiedR.toS
+    (H : HasTypeStratifiedR rank Γ e A b n r) :
+    HasTypeStratifiedS Γ e A b n := by
+  induction H with
+  | bvar h _ ih => exact .bvar h ih
+  | sort' => exact .sort'
+  | const hreg hlen _ _ ih => exact .const hreg hlen ih
+  | app _ _ _ _ _ ihA ihB ihf iha ihR => exact .app ihA ihB ihf iha ihR
+  | lam _ _ _ _ ihA ihB ihbody ihPi => exact .lam ihA ihB ihbody ihPi
+  | forallE _ _ ihA ihbody => exact .forallE ihA ihbody
+  | base _ ih => exact .base ih
+  | defeq h _ _ _ ihA ihB ihe => exact .defeq h ihA ihB ihe
+
+/-- The rank index is monotone. -/
+theorem HasTypeStratifiedR.mono_rank
+    (H : HasTypeStratifiedR rank Γ e A b n r) :
+    ∀ {r' : Nat}, r ≤ r' → HasTypeStratifiedR rank Γ e A b n r' := by
+  induction H with
+  | bvar h _ ih => exact fun hle => .bvar h (ih hle)
+  | sort' => exact fun _ => .sort'
+  | const hreg hlen hrank _ ih =>
+    exact fun hle => .const hreg hlen (Nat.le_trans hrank hle) (ih hle)
+  | app _ _ _ _ _ ihA ihB ihf iha ihR =>
+    exact fun hle => .app (ihA hle) (ihB hle) (ihf hle) (iha hle) (ihR hle)
+  | lam _ _ _ _ ihA ihB ihbody ihPi =>
+    exact fun hle => .lam (ihA hle) (ihB hle) (ihbody hle) (ihPi hle)
+  | forallE _ _ ihA ihbody => exact fun hle => .forallE (ihA hle) (ihbody hle)
+  | base _ ih => exact fun hle => .base (ih hle)
+  | defeq h _ _ _ ihA ihB ihe =>
+    exact fun hle => .defeq h (ihA hle) (ihB hle) (ihe hle)
+
+/-- Every ordinary stratified derivation admits some rank bound.  Thus the
+extra index is a recursion certificate, not a restriction on typing. -/
+theorem HasTypeStratifiedR.exists_rank (rank : Name → Nat)
+    (H : HasTypeStratifiedS Γ e A b n) :
+    ∃ r, HasTypeStratifiedR rank Γ e A b n r := by
+  induction H with
+  | bvar h _ ih => obtain ⟨r, hr⟩ := ih; exact ⟨r, .bvar h hr⟩
+  | sort' => exact ⟨0, .sort'⟩
+  | @const c ci Γ ls u n hreg hlen _ ih =>
+    obtain ⟨r, hr⟩ := ih
+    exact ⟨max (rank c) r,
+      .const hreg hlen (Nat.le_max_left ..)
+        (hr.mono_rank (Nat.le_max_right ..))⟩
+  | app _ _ _ _ _ ihA ihB ihf iha ihR =>
+    obtain ⟨r1, h1⟩ := ihA; obtain ⟨r2, h2⟩ := ihB
+    obtain ⟨r3, h3⟩ := ihf; obtain ⟨r4, h4⟩ := iha
+    obtain ⟨r5, h5⟩ := ihR
+    exact ⟨max (max (max r1 r2) (max r3 r4)) r5,
+      .app (h1.mono_rank (by omega)) (h2.mono_rank (by omega))
+        (h3.mono_rank (by omega)) (h4.mono_rank (by omega))
+        (h5.mono_rank (by omega))⟩
+  | lam _ _ _ _ ihA ihB ihbody ihPi =>
+    obtain ⟨r1, h1⟩ := ihA; obtain ⟨r2, h2⟩ := ihB
+    obtain ⟨r3, h3⟩ := ihbody; obtain ⟨r4, h4⟩ := ihPi
+    exact ⟨max (max r1 r2) (max r3 r4),
+      .lam (h1.mono_rank (by omega)) (h2.mono_rank (by omega))
+        (h3.mono_rank (by omega)) (h4.mono_rank (by omega))⟩
+  | forallE _ _ ihA ihbody =>
+    obtain ⟨r1, h1⟩ := ihA; obtain ⟨r2, h2⟩ := ihbody
+    exact ⟨max r1 r2, .forallE (h1.mono_rank (by omega))
+      (h2.mono_rank (by omega))⟩
+  | base _ ih => obtain ⟨r, hr⟩ := ih; exact ⟨r, .base hr⟩
+  | defeq h _ _ _ ihA ihB ihe =>
+    obtain ⟨r1, h1⟩ := ihA; obtain ⟨r2, h2⟩ := ihB
+    obtain ⟨r3, h3⟩ := ihe
+    exact ⟨max (max r1 r2) r3,
+      .defeq h (h1.mono_rank (by omega)) (h2.mono_rank (by omega))
+        (h3.mono_rank (by omega))⟩
+
+/-- Per-environment δ-termination data.  A registered definition supplies a
+typing certificate for its value strictly below the rank of the constant
+whose reduction exposes that value. -/
+class Params.DeltaRank [Params] : Type where
+  rank : Name → Nat
+  defnCert :
+    ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed}
+      {ls : List SLevel} {Γ : List SExpr},
+      Params.Pat (.const c) (.fixed value closed, .true) →
+      env.constants c = some ci →
+      ls.length = ci.uvars →
+      ∃ (nV rV : Nat), rV < rank c ∧
+        HasTypeStratifiedR rank Γ (SExpr.mkInst ls value)
+          (SExpr.mkInst ls ci.type) true nV rV
+
+/-- A definitional constant necessarily has positive δ-rank. -/
+theorem Params.DeltaRank.defn_pos [Params.DeltaRank]
+    {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed}
+    (hpat : Params.Pat (.const c) (.fixed value closed, .true))
+    (hreg : env.constants c = some ci) : 0 < Params.DeltaRank.rank c := by
+  obtain ⟨nV, rV, hlt, -⟩ := Params.DeltaRank.defnCert (Γ := [])
+    (ls := List.replicate ci.uvars SLevel.zero) hpat hreg
+    (List.length_replicate ..)
+  exact Nat.lt_of_le_of_lt (Nat.zero_le rV) hlt
+
+/-- info: 'Lean4Lean.SExpr.HasTypeStratifiedR.exists_rank' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms HasTypeStratifiedR.exists_rank
+
+/-- info: 'Lean4Lean.SExpr.Params.DeltaRank.defn_pos' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Params.DeltaRank.defn_pos
+
+/-- Every evidence-rich equality has stratified typings for both endpoints
+at one common depth.  The application and lambda cases are the reason the
+strong judgment retains codomain validity in both binder contexts: the
+right endpoint is first typed at its native dependent result and then
+transported back to the left-oriented conclusion type. -/
+theorem IsDefEqStrong.stratify (H : IsDefEqStrong Γ e₁ e₂ A) :
+    ∃ n, HasTypeStratifiedS Γ e₁ A true n ∧
+      HasTypeStratifiedS Γ e₂ A true n := by
+  induction H with
+  | bvar h _ ihA =>
+    obtain ⟨n, hA, _⟩ := ihA
+    exact ⟨n + 1, .base (.bvar h hA), .base (.bvar h hA)⟩
+  | symm _ ih =>
+    obtain ⟨n, h₁, h₂⟩ := ih
+    exact ⟨n, h₂, h₁⟩
+  | trans _ _ ih₁ ih₂ =>
+    obtain ⟨n₁, h₁, _⟩ := ih₁
+    obtain ⟨n₂, _, h₂⟩ := ih₂
+    exact ⟨max n₁ n₂, h₁.mono (Nat.le_max_left ..),
+      h₂.mono (Nat.le_max_right ..)⟩
+  | sort =>
+    exact ⟨0, .base .sort', .base .sort'⟩
+  | const hreg hlen _ _ _ _ ihTy _ _ =>
+    obtain ⟨n, hTy, _⟩ := ihTy
+    exact ⟨n + 1, .base (.const hreg hlen hTy),
+      .base (.const hreg hlen hTy)⟩
+  | @appDF Γ A u B v f f' a a' hA hCod hf ha hResult
+      ihA ihCod ihf iha ihResult =>
+    obtain ⟨nA, hA₁, _⟩ := ihA
+    obtain ⟨nCod, hCod₁, _⟩ := ihCod
+    obtain ⟨nf, hf₁, hf₂⟩ := ihf
+    obtain ⟨na, ha₁, ha₂⟩ := iha
+    obtain ⟨nR, hR₁, hR₂⟩ := ihResult
+    let k := max nA (max nCod (max nf (max na nR)))
+    have hleft : HasTypeStratifiedS Γ (.app f a) (B.inst a) true (k + 1) :=
+      .base (.app (hA₁.mono (by omega)) (hCod₁.mono (by omega))
+        (hf₁.mono (by omega)) (ha₁.mono (by omega))
+        (hR₁.mono (by omega)))
+    have hrightNative :
+        HasTypeStratifiedS Γ (.app f' a') (B.inst a') true (k + 1) :=
+      .base (.app (hA₁.mono (by omega)) (hCod₁.mono (by omega))
+        (hf₂.mono (by omega)) (ha₂.mono (by omega))
+        (hR₂.mono (by omega)))
+    have hright : HasTypeStratifiedS Γ (.app f' a') (B.inst a) true (k + 2) :=
+      .defeq hResult.symm
+        (hR₂.mono (by omega)) (hR₁.mono (by omega))
+        hrightNative
+    exact ⟨k + 2, hleft.mono (by omega), hright⟩
+  | @lamDF Γ A A' u B v body body' hA hB hB' hBody hBody'
+      ihA ihB ihB' ihBody ihBody' =>
+    obtain ⟨nA, hA₁, hA₂⟩ := ihA
+    obtain ⟨nB, hB₁, _⟩ := ihB
+    obtain ⟨nB', hB₁', hB₂'⟩ := ihB'
+    obtain ⟨nBody, hBody₁, _⟩ := ihBody
+    obtain ⟨nBody', _, hBody₂'⟩ := ihBody'
+    let k := max nA (max nB (max nB' (max nBody nBody')))
+    have hPi : HasTypeStratifiedS Γ (.forallE A B)
+        (.sort (.imax u v)) true (k + 1) :=
+      .base (.forallE (hA₁.mono (by omega)) (hB₁.mono (by omega)))
+    have hPi' : HasTypeStratifiedS Γ (.forallE A' B)
+        (.sort (.imax u v)) true (k + 1) :=
+      .base (.forallE (hA₂.mono (by omega)) (hB₂'.mono (by omega)))
+    have hleft : HasTypeStratifiedS Γ (.lam A body) (.forallE A B)
+        true (k + 2) :=
+      .base (.lam (hA₁.mono (by omega)) (hB₁.mono (by omega))
+        (hBody₁.mono (by omega)) hPi)
+    have hrightNative : HasTypeStratifiedS Γ (.lam A' body')
+        (.forallE A' B) true (k + 2) :=
+      .base (.lam (hA₂.mono (by omega)) (hB₂'.mono (by omega))
+        (hBody₂'.mono (by omega)) hPi')
+    have hPiEq : IsDefEqStrong Γ (.forallE A B) (.forallE A' B)
+        (.sort (.imax u v)) :=
+      .forallEDF hA hB hB'
+    have hright : HasTypeStratifiedS Γ (.lam A' body') (.forallE A B)
+        true (k + 3) :=
+      .defeq hPiEq.symm (hPi'.mono (by omega)) (hPi.mono (by omega))
+        hrightNative
+    exact ⟨k + 3, hleft.mono (by omega), hright⟩
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    obtain ⟨nA, hA₁, hA₂⟩ := ihA
+    obtain ⟨nB, hB₁, _⟩ := ihBody
+    obtain ⟨nB', _, hB₂⟩ := ihBody'
+    let k := max nA (max nB nB')
+    exact ⟨k + 1,
+      .base (.forallE (hA₁.mono (by omega)) (hB₁.mono (by omega))),
+      .base (.forallE (hA₂.mono (by omega)) (hB₂.mono (by omega)))⟩
+  | defeqDF hA _ ihA ihe =>
+    obtain ⟨nA, hA₁, hA₂⟩ := ihA
+    obtain ⟨ne, he₁, he₂⟩ := ihe
+    let k := max nA ne
+    exact ⟨k + 1,
+      .defeq hA (hA₁.mono (by omega)) (hA₂.mono (by omega))
+        (he₁.mono (by omega)),
+      .defeq hA (hA₁.mono (by omega)) (hA₂.mono (by omega))
+        (he₂.mono (by omega))⟩
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    obtain ⟨nApp, hApp, _⟩ := ihApp
+    obtain ⟨nInst, _, hInst⟩ := ihInst
+    exact ⟨max nApp nInst, hApp.mono (Nat.le_max_left ..),
+      hInst.mono (Nat.le_max_right ..)⟩
+  | eta _ _ ihe ihLam =>
+    obtain ⟨ne, _, he⟩ := ihe
+    obtain ⟨nLam, hLam, _⟩ := ihLam
+    exact ⟨max nLam ne, hLam.mono (Nat.le_max_left ..),
+      he.mono (Nat.le_max_right ..)⟩
+  | proofIrrel _ _ _ _ ihh ihh' =>
+    obtain ⟨nh, hh, _⟩ := ihh
+    obtain ⟨nh', _, hh'⟩ := ihh'
+    exact ⟨max nh nh', hh.mono (Nat.le_max_left ..),
+      hh'.mono (Nat.le_max_right ..)⟩
+  | defn hreg hlen _ _ _ _ _ ihTy _ ihRhs =>
+    obtain ⟨nTy, hTy, _⟩ := ihTy
+    obtain ⟨nRhs, _, hRhs⟩ := ihRhs
+    let k := max (nTy + 1) nRhs
+    exact ⟨k,
+      (HasTypeStratifiedS.base (.const hreg hlen hTy)).mono
+        (Nat.le_max_left ..),
+      hRhs.mono (Nat.le_max_right ..)⟩
+  | extra _ _ _ ihLeft ihRight =>
+    obtain ⟨nL, hL, _⟩ := ihLeft
+    obtain ⟨nR, _, hR⟩ := ihRight
+    exact ⟨max nL nR, hL.mono (Nat.le_max_left ..),
+      hR.mono (Nat.le_max_right ..)⟩
+
+/-- Erase only the stratification index, retaining the ordinary weak typing
+judgment. -/
+theorem HasTypeStratifiedS.hasType
+    (H : HasTypeStratifiedS Γ e A b n) : Γ ⊢ e : A := by
+  induction H with
+  | bvar h _ _ => exact .bvar h
+  | sort' => exact .sort
+  | const hreg hlen _ _ => exact .const hreg hlen
+  | app _ _ _ _ _ _ _ ihf iha _ => exact .appDF ihf iha
+  | lam _ _ _ _ ihA _ ihBody _ => exact .lamDF ihA ihBody
+  | forallE _ _ ihA ihBody => exact .forallEDF ihA ihBody
+  | base _ ih => exact ih
+  | defeq h _ _ _ _ _ ihe => exact h.defeq.defeqDF ihe
+
 theorem HasTypeStratifiedS.to_core (H : Γ ⊢ e : A !! n) :
-    ∃ A', Γ ⊢ e :! A' !! n := sorry
+    ∃ A', Γ ⊢ e :! A' !! n := by
+  generalize hb : true = b at H
+  induction H with cases hb
+  | base h _ => exact ⟨_, h⟩
+  | defeq _ _ _ _ _ _ ih =>
+    obtain ⟨A', hA'⟩ := ih rfl
+    exact ⟨A', hA'.mono (Nat.le_succ _)⟩
+
+/-- A stratified typing of a syntactic Pi exposes strictly shallower
+stratified typings for its domain and codomain.  Outer conversions are
+discarded by `to_core`; the remaining core derivation is forced to be the
+syntax-directed `forallE` constructor.  This is the depth information the
+joint adequacy/uniqueness induction needs in its application case. -/
+theorem HasTypeStratifiedS.forallE_inv
+    (H : HasTypeStratifiedS Γ (.forallE A B) V true n) :
+    ∃ u v,
+      HasTypeStratifiedS Γ A (.sort u) true (n - 1) ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort v) true (n - 1) := by
+  obtain ⟨V', H⟩ := H.to_core
+  cases H with
+  | forallE hA hB =>
+    exact ⟨_, _, by simpa using hA, by simpa using hB⟩
+
+/-- A stratified typing of a concrete application exposes every native
+typing premise one layer earlier.
+
+Outer displayed-type conversions are discarded by `to_core`; consequently
+the returned codomain is the one selected by the actual application
+derivation, rather than an independently reconstructed typing of the public
+result type.  Iterating this lemma down a focused registered RHS tower keeps
+the exact endpoint derivation and provides the strict depth decrease needed
+before rebuilding an evaluator edge. -/
+theorem HasTypeStratifiedS.app_inv
+    (H : HasTypeStratifiedS Γ (.app f a) V true n) :
+    ∃ A u B v,
+      HasTypeStratifiedS Γ A (.sort u) true (n - 1) ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort v) true (n - 1) ∧
+      HasTypeStratifiedS Γ f (.forallE A B) true (n - 1) ∧
+      HasTypeStratifiedS Γ a A true (n - 1) ∧
+      HasTypeStratifiedS Γ (B.inst a) (.sort v) true (n - 1) := by
+  obtain ⟨V', H⟩ := H.to_core
+  cases H with
+  | app hA hB hf ha hResult =>
+    exact ⟨_, _, _, _, by simpa using hA, by simpa using hB,
+      by simpa using hf, by simpa using ha, by simpa using hResult⟩
+
+/-- Iteratively peel a concrete left-associated application tower while
+retaining the native typing derivation of its literal head. -/
+theorem HasTypeStratifiedS.foldl_app_head
+    {args : List SExpr} {head V : SExpr}
+    (H : HasTypeStratifiedS Γ
+      (args.foldl (fun f a => f.app a) head) V true n) :
+    ∃ HeadType,
+      HasTypeStratifiedS Γ head HeadType true (n - args.length) := by
+  induction args generalizing head n V with
+  | nil => exact ⟨V, by simpa⟩
+  | cons arg args ih =>
+    simp only [List.foldl_cons] at H
+    obtain ⟨_, hHeadApp⟩ := ih H
+    obtain ⟨A, _, B, _, _, _, hHead, _, _⟩ := hHeadApp.app_inv
+    refine ⟨.forallE A B, ?_⟩
+    simpa only [List.length_cons, Nat.sub_sub, Nat.add_comm] using hHead
+
+/-- A well-typed nonempty left-associated application tower has positive
+stratification depth. -/
+theorem HasTypeStratifiedS.foldl_app_depth_pos
+    {args : List SExpr} {head V : SExpr}
+    (H : HasTypeStratifiedS Γ
+      (args.foldl (fun f a => f.app a) head) V true n)
+    (hne : args ≠ []) :
+    0 < n := by
+  induction args generalizing head n V with
+  | nil => exact (hne rfl).elim
+  | cons arg args ih =>
+    simp only [List.foldl_cons] at H
+    by_cases hrest : args = []
+    · subst args
+      simp only [List.foldl_nil] at H
+      obtain ⟨_, H⟩ := H.to_core
+      cases H with
+      | app => omega
+    · exact ih H hrest
+
+/-- A nonempty application tower exposes its literal head at a strictly
+smaller stratification depth. -/
+theorem HasTypeStratifiedS.foldl_app_head_of_ne_nil
+    {args : List SExpr} {head V : SExpr}
+    (H : HasTypeStratifiedS Γ
+      (args.foldl (fun f a => f.app a) head) V true n)
+    (hne : args ≠ []) :
+    ∃ HeadType depth,
+      depth < n ∧ HasTypeStratifiedS Γ head HeadType true depth := by
+  obtain ⟨HeadType, hHead⟩ := H.foldl_app_head
+  have hnpos : 0 < n := H.foldl_app_depth_pos hne
+  have hlen : 0 < args.length := by
+    cases args with
+    | nil => exact (hne rfl).elim
+    | cons => simp
+  exact ⟨HeadType, n - args.length, by omega, hHead⟩
+
+/-- Peel the concrete capture tower selected by an iota descriptor and
+retain the native stratified typing of its literal registered RHS head. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.rhsHeadStratified
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) {recLs : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {V : SExpr}
+    (H : HasTypeStratifiedS Γ (r.1.applyS recLs capture) V true depth) :
+    ∃ HeadType,
+      HasTypeStratifiedS Γ (SExpr.mkInst recLs rule.df.rhs) HeadType true
+        (depth - rule.capturePaths.length) := by
+  rw [← rule.rhsApply recLs capture] at H
+  simpa only [List.length_map] using H.foldl_app_head
+
+/-- A nonempty registered capture tower exposes its fixed RHS head at a
+strictly smaller depth than the typed instantiated endpoint. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.rhsHeadStratified_of_nonempty
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) {recLs : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {V : SExpr}
+    (H : HasTypeStratifiedS Γ (r.1.applyS recLs capture) V true depth)
+    (hne : rule.capturePaths ≠ []) :
+    ∃ HeadType headDepth,
+      headDepth < depth ∧
+        HasTypeStratifiedS Γ (SExpr.mkInst recLs rule.df.rhs)
+          HeadType true headDepth := by
+  rw [← rule.rhsApply recLs capture] at H
+  apply H.foldl_app_head_of_ne_nil
+  simpa using hne
 
 theorem HasTypeStratifiedS.isType (H : HasTypeStratifiedS Γ e A b n) :
-    ∃ u, Γ ⊢ A : .sort u !! n - 1 := sorry
+    ∃ u, Γ ⊢ A : .sort u !! n - 1 := by
+  induction H with
+  | base _ ih => exact ih
+  | bvar _ h => exact ⟨_, h⟩
+  | const _ _ h => exact ⟨_, h⟩
+  | app _ _ _ _ h => exact ⟨_, h⟩
+  | lam _ _ _ h => exact ⟨_, h⟩
+  | defeq _ _ h => exact ⟨_, h⟩
+  | @sort' _ l _ => exact ⟨_, .base (.sort' (l := l.succ))⟩
+  | @forallE _ A u _ body v _ _ => exact ⟨_, .base (.sort' (l := .imax u v))⟩
+
+/-- Reconstruct evidence-rich self-typing from a stratified typing.
+
+The stratified judgment retains every validity premise needed by
+`IsDefEqStrong`.  Its conversion constructor now also retains the strong
+type equality, so this proof is structural.  The constant case obtains the
+constructor and definition witnesses from `Params.Semantic`; it does not
+postulate a generic weak-to-strong conversion. -/
+theorem HasTypeStratifiedS.strong
+    [Params.Semantic] (H : HasTypeStratifiedS Γ e A b n) :
+    IsDefEqStrong Γ e e A := by
+  induction H with
+  | bvar h _ ihA =>
+    exact .bvar h ihA
+  | sort' =>
+    exact .sort
+  | @const c ci Γ ls u _ hreg hlen _ ihTy =>
+    let F : ∀ cl, CtorBundle c cl := fun cl =>
+      (Params.Semantic.ctor (ls := ls) (Γ := Γ) hreg hlen cl).1
+    have hF : ∀ cl, IsDefEqStrong Γ
+        (SExpr.mkInst ls ci.type) ((F cl).rhs ls) (.sort (F cl).u) := by
+      intro cl
+      exact (Params.Semantic.ctor (ls := ls) (Γ := Γ) hreg hlen cl).2
+    have hDef : ∀ {r : (Pattern.const c).RHS × (Pattern.const c).Check},
+        Params.Pat (.const c) r →
+        IsDefEqStrong Γ (r.1.applyS ls Empty.elim) (.const c ls)
+          (SExpr.mkInst ls ci.type) := by
+      intro r hpat
+      obtain ⟨value, closed, hr, hdef⟩ := Params.Semantic.defn hpat
+      subst r
+      simpa only [Pattern.RHS.applyS] using
+        (hdef hreg hlen : IsDefEqStrong Γ
+          (.const c ls) (SExpr.mkInst ls value)
+          (SExpr.mkInst ls ci.type)).symm
+    exact .const hreg hlen ihTy F hF hDef
+  | app _ _ _ _ _ ihA ihB ihf iha ihResult =>
+    exact .appDF ihA ihB ihf iha ihResult
+  | lam _ _ _ _ ihA ihB ihBody _ =>
+    exact .lamDF ihA ihB ihB ihBody ihBody
+  | forallE _ _ ihA ihBody =>
+    exact .forallEDF ihA ihBody ihBody
+  | base _ ih =>
+    exact ih
+  | defeq hType _ _ _ _ _ ihTerm =>
+    exact .defeqDF hType ihTerm
 
 def Ctx.WF : List SExpr → Prop
   | [] => True
   | A::Γ => WF Γ ∧ ∃ u, Γ ⊢ A : .sort u
 scoped notation:65 "⊢ " Γ:36 => Ctx.WF Γ
 
+/-! ## Reflection and evidence recovery
+
+Once heterogeneous transitivity has been eliminated, the weak SExpr
+judgment reflects into the ordinary Theory judgment constructor for
+constructor.  Reification is exactly homomorphic for term lifting and
+substitution; universe `succ`, `imax`, and `instL` commute only modulo the
+semantic level quotient, so those cases use Theory's proved
+`EqUpToLevels` transport. -/
+
+theorem reify_lift' (e : SExpr) : (e.lift' ρ).reify = e.reify.lift' ρ := by
+  induction e generalizing ρ <;> simp [SExpr.lift', SExpr.reify, VExpr.lift', *]
+
+theorem reify_subst (e : SExpr) :
+    (e.subst σ).reify = e.reify.subst (fun i => (σ i).reify) := by
+  induction e generalizing σ with
+  | bvar => rfl
+  | sort => rfl
+  | const => rfl
+  | app f a ihf iha =>
+    simp only [SExpr.subst, SExpr.reify, VExpr.subst, ihf, iha]
+  | lam A e ihA ihe | forallE A e ihA ihe =>
+    simp only [SExpr.subst, SExpr.reify, VExpr.subst, ihA]
+    rw [ihe]
+    congr 2
+    funext i
+    cases i with
+    | zero => rfl
+    | succ i =>
+      simp [SExpr.Subst.lift, VExpr.Subst.lift, reify_lift',
+        VExpr.lift_eq_lift']
+
+theorem reify_inst (e a : SExpr) :
+    (e.inst a).reify = e.reify.inst a.reify := by
+  rw [SExpr.inst, VExpr.inst_eq, reify_subst]
+  congr 2
+  funext i
+  cases i <;> rfl
+
+theorem Lookup.reify (H : SExpr.Lookup Γ i A) :
+    Lean4Lean.Lookup (Γ.map SExpr.reify) i A.reify := by
+  induction H with
+  | zero =>
+    rw [reify_lift', ← VExpr.lift_eq_lift']
+    exact Lean4Lean.Lookup.zero
+  | succ _ ih =>
+    rw [reify_lift', ← VExpr.lift_eq_lift']
+    exact Lean4Lean.Lookup.succ ih
+
+theorem _root_.Lean4Lean.VEnv.EqUpToLevels.reify_of_mk_eq
+    (he : e.LevelWF Params.univs) (h : SExpr.mk e = s) :
+    VEnv.EqUpToLevels Params.univs e s.reify := by
+  subst s
+  exact VEnv.EqUpToLevels.reify_mk he
+
+theorem _root_.Lean4Lean.VEnv.EqUpToLevels.reify_refl (e : SExpr) :
+    VEnv.EqUpToLevels Params.univs e.reify e.reify := by
+  simpa only [SExpr.mk_reify] using
+    (VEnv.EqUpToLevels.reify_mk (SExpr.reify_levelWF e))
+
+theorem mk_instL_map_reify (e : VExpr) (ls : List SLevel) :
+    SExpr.mk (e.instL (ls.map SLevel.reify)) = SExpr.mkInst ls e := by
+  let vls := ls.map SLevel.reify
+  have hlevels : ∀ l ∈ vls, l.WF Params.univs := by
+    intro l hl
+    simp only [vls, List.mem_map] at hl
+    obtain ⟨sl, _, rfl⟩ := hl
+    exact SLevel.reify_wf sl
+  have hvls : vls.map SLevel.mk = ls := by
+    change (ls.map SLevel.reify).map SLevel.mk = ls
+    rw [List.map_map]
+    exact List.map_id''' ls fun sl _ => SLevel.mk_reify sl
+  have h := (SExpr.mkInst_map_mk (e := e) hlevels).symm
+  rw [hvls] at h
+  exact h
+
+/-- Simultaneously change both endpoints and the declared type of a Theory
+judgment along universe-representative equivalence.  This uses only the
+proved ordered-environment strengthening layer. -/
+theorem _root_.Lean4Lean.VEnv.IsDefEq.alignEqUpToLevels
+    (hΓ : OnCtx Γ (Params.env.IsType Params.univs))
+    (H : Params.env.IsDefEq Params.univs Γ e₁ e₂ A)
+    (he₁ : VEnv.EqUpToLevels Params.univs e₁ e₁')
+    (he₂ : VEnv.EqUpToLevels Params.univs e₂ e₂')
+    (hA : VEnv.EqUpToLevels Params.univs A A') :
+    Params.env.IsDefEq Params.univs Γ e₁' e₂' A' := by
+  let W := VEnv.CtxStrong.strong Params.henv hΓ
+  have hs := H.strong Params.henv hΓ
+  have hterm :=
+    VEnv.EqUpToLevels.defeq Params.henv Params.henv.strong W hs he₁ he₂
+  obtain ⟨u, htype⟩ := hs.isType' Params.henv Params.henv.strong W
+  have hrefl := (VEnv.EqUpToLevels.refl W.levelWF htype).1
+  have htype' := VEnv.EqUpToLevels.defeq Params.henv Params.henv.strong W
+    htype hrefl hA
+  exact .defeqDF htype'.defeq hterm.defeq
+
+/-- Reflect the quotient syntax's weak judgment back into Theory.  The
+target context validity is explicit so binder cases can extend it with the
+typing recovered from their translated premises. -/
+theorem IsDefEq.reify (H : IsDefEq Γ e₁ e₂ A) :
+    OnCtx (Γ.map SExpr.reify) (Params.env.IsType Params.univs) →
+    Params.env.IsDefEq Params.univs (Γ.map SExpr.reify)
+      e₁.reify e₂.reify A.reify := by
+  intro hΓ
+  induction H with
+  | bvar h => exact .bvar h.reify
+  | symm _ ih => exact (ih hΓ).symm
+  | trans _ _ ih₁ ih₂ => exact (ih₁ hΓ).trans (ih₂ hΓ)
+  | @sort Γ l =>
+    have hl : l.reify.WF Params.univs := SLevel.reify_wf l
+    have hbase : Params.env.IsDefEq Params.univs (Γ.map SExpr.reify)
+        (.sort l.reify) (.sort l.reify) (.sort l.reify.succ) :=
+      .sortDF hl hl rfl
+    have htype : VEnv.EqUpToLevels Params.univs
+        (VExpr.sort l.reify.succ) (SExpr.sort l.succ).reify :=
+      .reify_of_mk_eq (show l.reify.succ.WF Params.univs from hl)
+        (by simp only [SExpr.mk, SLevel.mk_succ hl, SLevel.mk_reify])
+    exact hbase.alignEqUpToLevels hΓ
+      (.reify_refl (SExpr.sort l)) (.reify_refl (SExpr.sort l)) htype
+  | @const c ci Γ ls hreg hlen =>
+    let vls := ls.map SLevel.reify
+    have hlevels : ∀ l ∈ vls, l.WF Params.univs := by
+      intro l hl
+      simp only [vls, List.mem_map] at hl
+      obtain ⟨sl, _, rfl⟩ := hl
+      exact SLevel.reify_wf sl
+    have hbase : Params.env.IsDefEq Params.univs (Γ.map SExpr.reify)
+        (.const c vls) (.const c vls) (ci.type.instL vls) :=
+      .constDF hreg hlevels hlevels (by simpa [vls] using hlen)
+        (List.Forall₂.rfl fun _ _ => rfl)
+    let W := VEnv.CtxStrong.strong Params.henv hΓ
+    have htype : VEnv.EqUpToLevels Params.univs
+        (ci.type.instL vls) (SExpr.mkInst ls ci.type).reify :=
+      .reify_of_mk_eq (hbase.levelWF W.levelWF).2.2
+        (by simpa only [vls] using mk_instL_map_reify ci.type ls)
+    exact hbase.alignEqUpToLevels hΓ
+      (.reify_refl (SExpr.const c ls)) (.reify_refl (SExpr.const c ls)) htype
+  | @appDF Γ f f' A B a a' _ _ ihf iha =>
+    simpa only [SExpr.reify, reify_inst] using
+      VEnv.IsDefEq.appDF (ihf hΓ) (iha hΓ)
+  | @lamDF Γ A A' u body body' B _ _ ihA ihBody =>
+    have hA := ihA hΓ
+    have hΓ' : OnCtx (A.reify :: Γ.map SExpr.reify)
+        (Params.env.IsType Params.univs) :=
+      ⟨hΓ, ⟨_, hA.hasType.1⟩⟩
+    exact .lamDF hA (ihBody hΓ')
+  | @forallEDF Γ A A' u body body' v _ _ ihA ihBody =>
+    have hA := ihA hΓ
+    have hΓ' : OnCtx (A.reify :: Γ.map SExpr.reify)
+        (Params.env.IsType Params.univs) :=
+      ⟨hΓ, ⟨_, hA.hasType.1⟩⟩
+    have hbase := VEnv.IsDefEq.forallEDF hA (ihBody hΓ')
+    have hu : u.reify.WF Params.univs := SLevel.reify_wf u
+    have hv : v.reify.WF Params.univs := SLevel.reify_wf v
+    have htype : VEnv.EqUpToLevels Params.univs
+        (VExpr.sort (.imax u.reify v.reify)) (SExpr.sort (.imax u v)).reify :=
+      .reify_of_mk_eq
+        (show (VLevel.imax u.reify v.reify).WF Params.univs from ⟨hu, hv⟩)
+        (by simp only [SExpr.mk, SLevel.mk_imax hu hv, SLevel.mk_reify])
+    exact hbase.alignEqUpToLevels hΓ
+      (.reify_refl (SExpr.forallE A body))
+      (.reify_refl (SExpr.forallE A' body')) htype
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA hΓ) (ihe hΓ)
+  | @beta A Γ e B e' _ _ ihBody ihArg =>
+    have harg := ihArg hΓ
+    have hΓ' : OnCtx (A.reify :: Γ.map SExpr.reify)
+        (Params.env.IsType Params.univs) :=
+      ⟨hΓ, harg.isType Params.henv hΓ⟩
+    simpa only [SExpr.reify, reify_inst] using
+      VEnv.IsDefEq.beta (ihBody hΓ') harg
+  | @eta Γ e A B _ ihe =>
+    simpa only [SExpr.reify, reify_lift', ← VExpr.lift_eq_lift'] using
+      VEnv.IsDefEq.eta (ihe hΓ)
+  | @proofIrrel Γ p h h' _ _ _ ihp ihh ihh' =>
+    have hp := ihp hΓ
+    have hz : SLevel.zero.reify ≈ VLevel.zero :=
+      SLevel.equiv_of_mk_eq (SLevel.reify_wf .zero) (by trivial)
+        (by simp only [SLevel.mk_reify, SLevel.mk_zero])
+    have hp' := hp.alignEqUpToLevels hΓ
+      (.reify_refl p) (.reify_refl p)
+      (VEnv.EqUpToLevels.sort (SLevel.reify_wf .zero) (by trivial) hz)
+    exact .proofIrrel hp' (ihh hΓ) (ihh' hΓ)
+  | @extra df Γ ls hreg hlen =>
+    let vls := ls.map SLevel.reify
+    have hlevels : ∀ l ∈ vls, l.WF Params.univs := by
+      intro l hl
+      simp only [vls, List.mem_map] at hl
+      obtain ⟨sl, _, rfl⟩ := hl
+      exact SLevel.reify_wf sl
+    have hbase : Params.env.IsDefEq Params.univs (Γ.map SExpr.reify)
+        (df.lhs.instL vls) (df.rhs.instL vls) (df.type.instL vls) :=
+      .extra hreg hlevels (by simpa [vls] using hlen)
+    let W := VEnv.CtxStrong.strong Params.henv hΓ
+    have hwf := hbase.levelWF W.levelWF
+    have hlhs : VEnv.EqUpToLevels Params.univs
+        (df.lhs.instL vls) (SExpr.mkInst ls df.lhs).reify :=
+      .reify_of_mk_eq hwf.1
+        (by simpa only [vls] using mk_instL_map_reify df.lhs ls)
+    have hrhs : VEnv.EqUpToLevels Params.univs
+        (df.rhs.instL vls) (SExpr.mkInst ls df.rhs).reify :=
+      .reify_of_mk_eq hwf.2.1
+        (by simpa only [vls] using mk_instL_map_reify df.rhs ls)
+    have htype : VEnv.EqUpToLevels Params.univs
+        (df.type.instL vls) (SExpr.mkInst ls df.type).reify :=
+      .reify_of_mk_eq hwf.2.2
+        (by simpa only [vls] using mk_instL_map_reify df.type ls)
+    exact hbase.alignEqUpToLevels hΓ hlhs hrhs htype
+
+/-- A well-formed SExpr context reifies to a well-formed Theory context. -/
+theorem Ctx.WF.reify (H : Ctx.WF Γ) :
+    OnCtx (Γ.map SExpr.reify) (Params.env.IsType Params.univs) := by
+  induction Γ with
+  | nil => trivial
+  | cons A Γ ih =>
+    obtain ⟨hΓ, u, hA⟩ := H
+    have hΓ' := ih hΓ
+    exact ⟨hΓ', ⟨u.reify, hA.reify hΓ'⟩⟩
+
+/-- Translate a well-formed Theory context through `SExpr.mk`.  This is the
+context counterpart of `VEnv.IsDefEqStrong.mkS`; generated reduction sites
+and the contextual adequacy tower use the two translations together. -/
+theorem Ctx.WF.mkS [Params.Semantic]
+    (H : OnCtx Γ (Params.env.IsType Params.univs)) :
+    Ctx.WF (Γ.map SExpr.mk) := by
+  induction Γ with
+  | nil => trivial
+  | cons A Γ ih =>
+    obtain ⟨hΓ, u, hA⟩ := H
+    have hΓS := ih hΓ
+    have hAS := (hA.strong Params.henv hΓ).mkS
+    exact ⟨hΓS, ⟨SLevel.mk u, hAS.defeq⟩⟩
+
+/-- Recover the proof-carrying judgment from a weak SExpr derivation in a
+well-formed context.  The proof reflects to Theory, uses its clean ordered
+environment strengthening theorem, and translates back; it does not depend
+on Theory's transitional uniqueness or injectivity declarations. -/
+theorem IsDefEq.strong [Params.Semantic]
+    (hΓ : Ctx.WF Γ) (H : IsDefEq Γ e₁ e₂ A) :
+    IsDefEqStrong Γ e₁ e₂ A := by
+  have hΓ' := hΓ.reify
+  have hV := (H.reify hΓ').strong Params.henv hΓ'
+  have hS := hV.mkS
+  have hctx : (Γ.map SExpr.reify).map SExpr.mk = Γ := by
+    rw [List.map_map]
+    exact List.map_id''' Γ fun term _ => SExpr.mk_reify term
+  simpa only [hctx, SExpr.mk_reify] using hS
+
 variable (HasType : List SExpr → SExpr → SExpr → Prop)
 inductive Ctx.Subst (Γ : List SExpr) : SExpr.Subst → List SExpr → Prop where
   | nil : Ctx.Subst Γ σ []
@@ -754,58 +3174,158 @@ theorem Ctx.Subst.head (H : Ctx.Subst HasType Γ σ (A::Δ)) : HasType Γ σ.hea
 theorem Ctx.Subst.tail (H : Ctx.Subst HasType Γ σ (A::Δ)) : Ctx.Subst HasType Γ σ.tail Δ :=
   let .cons H _ := H; H
 
+theorem Ctx.Subst.lookup (H : Ctx.Subst HasType Γ σ Δ) :
+    Lookup Δ i A → HasType Γ (σ i) (A.subst σ) := by
+  intro h
+  induction H generalizing i A with
+  | nil => cases h
+  | @cons Δ σ A₀ H hhead ih =>
+    cases h with
+    | zero =>
+      simpa only [show σ 0 = σ.head from rfl, SExpr.lift_subst] using hhead
+    | succ h =>
+      change HasType Γ (σ.tail _) (_)
+      simpa only [SExpr.lift_subst] using ih h
+
+/-- Change only the evidence relation carried by a substitution. -/
+theorem Ctx.Subst.imp
+    (f : ∀ {Γ e A}, HasType Γ e A → HasType' Γ e A)
+    (H : Ctx.Subst HasType Γ σ Δ) : Ctx.Subst HasType' Γ σ Δ := by
+  induction H with
+  | nil => exact .nil
+  | cons _ h ih => exact .cons ih (f h)
+
 theorem Ctx.Subst.cons' (H1 : Ctx.Subst HasType Γ σ Δ) (H2 : HasType Γ e (A.subst σ)) :
     Ctx.Subst HasType Γ (σ.cons e) (A::Δ) := .cons H1 H2
 
-theorem Ctx.Subst.lift_r (H1 : Ctx.Subst HasType Θ σ Γ) (H2 : Ctx.Lift' ρ Θ Δ) :
-    Ctx.Subst HasType Δ (σ.lift_r ρ) Γ := sorry
-
-theorem Ctx.Subst.lift (bvar : ∀ {Γ i A}, Lookup Γ i A → HasType Γ (bvar i) A)
+theorem Ctx.Subst.lift_r
+    (weak : ∀ {Γ Δ e A ρ}, Ctx.Lift' ρ Γ Δ → HasType Γ e A →
+      HasType Δ (e.lift' ρ) (A.lift' ρ))
+    (H1 : Ctx.Subst HasType Θ σ Γ) (H2 : Ctx.Lift' ρ Θ Δ) :
+    Ctx.Subst HasType Δ (σ.lift_r ρ) Γ := by
+  induction H1 with
+  | nil => exact .nil
+  | @cons Δ' σ' A H h ih =>
+    refine .cons ih ?_
+    change HasType Δ (σ'.head.lift' ρ) (A.subst (σ'.tail.lift_r ρ))
+    rw [← SExpr.lift'_subst]
+    exact weak H2 h
+
+theorem Ctx.Subst.lift
+    (weak : ∀ {Γ Δ e A ρ}, Ctx.Lift' ρ Γ Δ → HasType Γ e A →
+      HasType Δ (e.lift' ρ) (A.lift' ρ))
+    (bvar : ∀ {Γ i A}, Lookup Γ i A → HasType Γ (bvar i) A)
     (H : Ctx.Subst HasType Γ σ Δ) : Ctx.Subst HasType (A.subst σ :: Γ) σ.lift (A :: Δ) := by
   have : σ.lift.tail = σ.lift_r (.skip .refl) := by
     funext i; simp [SExpr.Subst.tail, SExpr.Subst.lift, SExpr.Subst.lift_r]
-  refine .cons (this ▸ .lift_r H .one) (this ▸ bvar ?_)
+  refine .cons (this ▸ .lift_r weak H .one) (this ▸ bvar ?_)
   rw [← lift'_subst, ← SExpr.lift]; exact .zero
 
-theorem Ctx.Subst.id : Ctx.Subst HasType Γ .id Γ := sorry
-theorem Ctx.Subst.one (H : HasType Γ e A) : Ctx.Subst HasType Γ (.one e) (A::Γ) :=
-  .cons .id (by simpa)
+theorem Ctx.Subst.id
+    (weak : ∀ {Γ Δ e A ρ}, Ctx.Lift' ρ Γ Δ → HasType Γ e A →
+      HasType Δ (e.lift' ρ) (A.lift' ρ))
+    (bvar : ∀ {Γ i A}, Lookup Γ i A → HasType Γ (bvar i) A) :
+    ∀ {Γ}, Ctx.Subst HasType Γ .id Γ
+  | [] => .nil
+  | A :: Γ => by
+    have htail : SExpr.Subst.id.tail = SExpr.Subst.id.lift_r (.skip .refl) := by
+      funext i
+      rfl
+    refine .cons (htail ▸ (Ctx.Subst.id weak bvar).lift_r weak (.skip .refl)) ?_
+    change HasType (A :: Γ) (.bvar 0) (A.subst SExpr.Subst.id.tail)
+    rw [htail, ← SExpr.lift'_subst, SExpr.subst_id]
+    exact bvar .zero
+
+theorem Ctx.Subst.one
+    (weak : ∀ {Γ Δ e A ρ}, Ctx.Lift' ρ Γ Δ → HasType Γ e A →
+      HasType Δ (e.lift' ρ) (A.lift' ρ))
+    (bvar : ∀ {Γ i A}, Lookup Γ i A → HasType Γ (bvar i) A)
+    (H : HasType Γ e A) : Ctx.Subst HasType Γ (.one e) (A::Γ) :=
+  .cons (.id weak bvar) (by simpa)
 
 inductive Ctx.SubstEq (Γ₀ : List SExpr) : SExpr.Subst → SExpr.Subst → List SExpr → Prop where
   | nil : Ctx.SubstEq Γ₀ .id .id Γ₀
+  /-- A pure context embedding is an equality substitution.  This base case
+  is what makes equality substitutions stable under entering a binder; the
+  old identity-only relation could not represent the weakened tail of a
+  lifted substitution. -/
+  | ofLift : Ctx.Lift' ρ Γ Γ₀ → Ctx.SubstEq Γ₀ ρ.toSubst ρ.toSubst Γ
   | cons : Ctx.SubstEq Γ₀ σ.tail σ'.tail Γ →
     Γ ⊢ A : .sort u →
     Γ₀ ⊢ σ.head ≡ σ'.head : A.subst σ.tail →
     Ctx.SubstEq Γ₀ σ σ' (A :: Γ)
 
+theorem Ctx.Subst.ofLookup
+    (H : ∀ {i A}, Lookup Δ i A → HasType Γ (σ i) (A.subst σ)) :
+    Ctx.Subst HasType Γ σ Δ := by
+  induction Δ generalizing σ with
+  | nil => exact .nil
+  | cons A Δ ih =>
+    refine .cons (ih (σ := σ.tail) fun {i B} h => ?_) ?_
+    · change HasType Γ (σ (i + 1)) (B.subst σ.tail)
+      simpa only [SExpr.lift_subst] using H (.succ h)
+    · change HasType Γ (σ 0) (A.subst σ.tail)
+      simpa only [SExpr.lift_subst] using H (.zero (ty := A) (Γ := Δ))
+
+theorem Ctx.Lift'.toSubst (W : Ctx.Lift' ρ Γ Γ') :
+    Ctx.Subst (· ⊢ · : ·) Γ' ρ.toSubst Γ := by
+  apply Ctx.Subst.ofLookup
+  intro i A h
+  simpa only [Lift.toSubst_apply, SExpr.subst_toSubst] using
+    (IsDefEq.bvar (h.weak' W))
+
 theorem Ctx.SubstEq.left (W : Ctx.SubstEq Γ₀ σ σ' Γ) : Ctx.Subst (· ⊢ · : ·) Γ₀ σ Γ := by
   induction W with
-  | nil => exact .id
+  | nil =>
+    apply Ctx.Subst.ofLookup
+    intro i A h
+    change Γ₀ ⊢ SExpr.Subst.id i : A.subst SExpr.Subst.id
+    rw [SExpr.subst_id]
+    exact IsDefEq.bvar h
+  | ofLift W => exact W.toSubst
   | cons _ _ h ih => exact .cons ih h.hasType.1
 
-theorem IsDefEq.subst (W : Ctx.SubstEq Γ₀ σ σ' Γ) :
-    Γ ⊢ e1 ≡ e2 : A → Γ₀ ⊢ e1.subst σ ≡ e2.subst σ' : A.subst σ := sorry
-
-theorem Ctx.SubstEq.symm (W : Ctx.SubstEq Γ₀ σ σ' Γ) : Ctx.SubstEq Γ₀ σ' σ Γ := by
+/-- Forget the right side of an equality substitution while retaining the
+same evidence format.  This is the diagonal used by simultaneous
+heterogeneous substitution proofs. -/
+theorem Ctx.SubstEq.leftEq (W : Ctx.SubstEq Γ₀ σ σ' Γ) :
+    Ctx.SubstEq Γ₀ σ σ Γ := by
   induction W with
   | nil => exact .nil
-  | cons W hA h ih => exact .cons ih hA (.defeqDF (.subst W hA) h.symm)
+  | ofLift W => exact .ofLift W
+  | cons _ hA hhead ih => exact .cons ih hA hhead.hasType.1
 
 theorem Ctx.SubstEq.lookup (W : Ctx.SubstEq Γ₀ σ σ' Γ) :
-    Lookup Γ i A → Γ₀ ⊢ σ i ≡ σ' i : A.subst σ := sorry
-
-theorem Ctx.SubstEq.lift (W : Ctx.SubstEq Γ₀ σ σ' Γ) (hA : Γ₀ ⊢ A.subst σ : .sort u) :
-    Ctx.SubstEq (A.subst σ :: Γ₀) σ.lift σ'.lift (A :: Γ) := sorry
-
-theorem IsDefEq.weak' (W : Ctx.Lift' ρ Γ Γ') (H : Γ ⊢ e1 ≡ e2 : A) :
+    Lookup Γ i A → Γ₀ ⊢ σ i ≡ σ' i : A.subst σ := by
+  intro h
+  induction W generalizing i A with
+  | nil =>
+    change Γ₀ ⊢ .bvar i ≡ .bvar i : A.subst .id
+    rw [subst_id]
+    exact .bvar h
+  | ofLift W =>
+    simpa only [Lift.toSubst_apply, SExpr.subst_toSubst] using
+      (IsDefEq.bvar (h.weak' W))
+  | cons W' hA' hhead ih =>
+    cases h with
+    | zero =>
+      simp only [show ∀ (s : SExpr.Subst), s 0 = s.head from fun _ => rfl, lift_subst]
+      exact hhead
+    | succ h' =>
+      simp only [show ∀ (s : SExpr.Subst) n, s (n+1) = s.tail n from fun _ _ => rfl,
+        lift_subst]
+      exact ih h'
+
+/-- The core weakening proof is placed before equality-substitution lifting:
+the latter must weaken every equality stored in the substitution. -/
+theorem IsDefEq.weakCore (W : Ctx.Lift' ρ Γ Γ') (H : Γ ⊢ e1 ≡ e2 : A) :
     Γ' ⊢ e1.lift' ρ ≡ e2.lift' ρ : A.lift' ρ := by
   induction H generalizing ρ Γ' with
   | bvar h => refine .bvar (h.weak' W)
   | symm _ ih => exact .symm (ih W)
   | trans _ _ ih1 ih2 => exact .trans (ih1 W) (ih2 W)
-  | trans' _ _ ih1 ih2 => exact .trans' (ih1 W) (ih2 W)
   | sort => exact .sort
-  | const h1 h2 => rw [(henv.closedC h1).mkS.instL.lift'_eq .zero]; exact .const h1 h2
+  | const h1 h2 => rw [((henv.closedC h1).mkInstS).lift'_eq .zero]; exact .const h1 h2
   | appDF _ _ ih1 ih2 => exact SExpr.lift'_inst_hi .. ▸ .appDF (ih1 W) (ih2 W)
   | lamDF _ _ ih1 ih2 => exact .lamDF (ih1 W) (ih2 W.cons)
   | forallEDF _ _ ih1 ih2 => exact .forallEDF (ih1 W) (ih2 W.cons)
@@ -817,12 +3337,394 @@ theorem IsDefEq.weak' (W : Ctx.Lift' ρ Γ Γ') (H : Γ ⊢ e1 ≡ e2 : A) :
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
   | extra h1 h2 =>
     have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
-    rw [hA1.mkS.instL.lift'_eq .zero, hA2.mkS.instL.lift'_eq .zero, hA3.mkS.instL.lift'_eq .zero]
+    rw [hA1.mkInstS.lift'_eq .zero, hA2.mkInstS.lift'_eq .zero,
+      hA3.mkInstS.lift'_eq .zero]
     exact .extra h1 h2
 
+theorem Ctx.SubstEq.weak' (W₀ : Ctx.Lift' ρ Γ₀ Γ₁)
+    (W : Ctx.SubstEq Γ₀ σ σ' Γ) :
+    Ctx.SubstEq Γ₁ (σ.lift_r ρ) (σ'.lift_r ρ) Γ := by
+  induction W with
+  | nil =>
+    have hσ : SExpr.Subst.id.lift_r ρ = ρ.toSubst := by
+      funext i
+      rfl
+    simpa only [hσ] using Ctx.SubstEq.ofLift W₀
+  | @ofLift ρ' Γ' W' =>
+    have h := Ctx.SubstEq.ofLift (W'.comp W₀)
+    have heq : ρ'.toSubst.lift_r ρ = (ρ'.comp ρ).toSubst := by
+      funext i
+      simp only [SExpr.Subst.lift_r, Lift.toSubst_apply, SExpr.lift',
+        Lift.liftVar_comp]
+    simpa only [heq] using h
+  | @cons Γ' A u τ τ' W hA hhead ih =>
+    have ht : (τ.lift_r ρ).tail = τ.tail.lift_r ρ := by
+      funext i
+      rfl
+    have ht' : (τ'.lift_r ρ).tail = τ'.tail.lift_r ρ := by
+      funext i
+      rfl
+    refine .cons ?_ hA ?_
+    · simpa only [ht, ht'] using ih
+    · rw [ht, ← SExpr.lift'_subst]
+      exact hhead.weakCore W₀
+
+theorem Ctx.SubstEq.lift (W : Ctx.SubstEq Γ₀ σ σ' Γ)
+    (hA : Γ ⊢ A : .sort u) :
+    Ctx.SubstEq (A.subst σ :: Γ₀) σ.lift σ'.lift (A :: Γ) := by
+  have W' := W.weak' (Ctx.Lift'.one (Γ := Γ₀) (A := A.subst σ))
+  have hσ : σ.lift.tail = σ.lift_r (.skip .refl) := by
+    funext i
+    rfl
+  have hσ' : σ'.lift.tail = σ'.lift_r (.skip .refl) := by
+    funext i
+    rfl
+  refine .cons (σ := σ.lift) (σ' := σ'.lift) ?_ hA ?_
+  · simpa only [hσ, hσ'] using W'
+  · rw [hσ, ← SExpr.lift'_subst]
+    exact IsDefEq.bvar (Lookup.zero (ty := A.subst σ) (Γ := Γ₀))
+
+theorem IsDefEq.weak' (W : Ctx.Lift' ρ Γ Γ') (H : Γ ⊢ e1 ≡ e2 : A) :
+    Γ' ⊢ e1.lift' ρ ≡ e2.lift' ρ : A.lift' ρ := H.weakCore W
+
+/-- Weak definitional equality is stable under one typed substitution.
+
+The two endpoints deliberately use the same substitution.  Heterogeneous
+substitution needs the domain/codomain evidence retained by
+`IsDefEqStrong`; erasing that evidence first makes the corresponding claim
+false for dependent application and beta. -/
+theorem IsDefEq.subst (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Γ₀ σ Γ)
+    (H : Γ ⊢ e1 ≡ e2 : A) :
+    Γ₀ ⊢ e1.subst σ ≡ e2.subst σ : A.subst σ := by
+  induction H generalizing Γ₀ σ with
+  | bvar h => exact W.lookup h
+  | symm _ ih => exact (ih W).symm
+  | trans _ _ ih₁ ih₂ => exact (ih₁ W).trans (ih₂ W)
+  | sort => exact .sort
+  | const hreg hlen =>
+    rw [((henv.closedC hreg).mkInstS).subst_eq .zero]
+    exact .const hreg hlen
+  | appDF _ _ ihf iha =>
+    rw [SExpr.subst_inst]
+    exact .appDF (ihf W) (iha W)
+  | lamDF _ _ ihA ihBody =>
+    exact .lamDF (ihA W)
+      (by simpa only [SExpr.subst] using
+        ihBody (W.lift IsDefEq.weakCore IsDefEq.bvar))
+  | forallEDF _ _ ihA ihBody =>
+    exact .forallEDF (ihA W)
+      (by simpa only [SExpr.subst] using
+        ihBody (W.lift IsDefEq.weakCore IsDefEq.bvar))
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA W) (ihe W)
+  | beta _ _ ihBody ihArg =>
+    simpa only [SExpr.subst, SExpr.subst_inst] using
+      (IsDefEq.beta
+        (by simpa only [SExpr.subst] using
+          ihBody (W.lift IsDefEq.weakCore IsDefEq.bvar))
+        (ihArg W))
+  | @eta Γ e A B _ ihe =>
+    have hout := IsDefEq.eta (ihe W)
+    have htail : σ.lift.tail = σ.lift_r (.skip .refl) := by
+      funext i
+      rfl
+    have heq : e.lift.subst σ.lift = (e.subst σ).lift := by
+      rw [SExpr.lift_subst, htail, ← SExpr.lift'_subst]
+    simpa only [SExpr.subst, SExpr.Subst.lift, heq] using hout
+  | proofIrrel _ _ _ ihp ihh ihh' =>
+    exact .proofIrrel (ihp W) (ihh W) (ihh' W)
+  | extra hreg hlen =>
+    have ⟨⟨hlhs, _⟩, hrhs, htype⟩ := henv.closed.2 hreg
+    rw [hlhs.mkInstS.subst_eq .zero, hrhs.mkInstS.subst_eq .zero,
+      htype.mkInstS.subst_eq .zero]
+    exact .extra hreg hlen
+
+/-- A strong derivation retains enough local validity evidence to show that
+each endpoint respects an equality substitution.  Both conclusions are
+typed at the left-substituted source type; keeping them together makes
+symmetry and transitivity structural instead of requiring an invalid
+symmetry operation on weak equality substitutions. -/
+theorem IsDefEqStrong.substCongr (W : Ctx.SubstEq Γ₀ σ σ' Γ)
+    (H : IsDefEqStrong Γ e1 e2 A) :
+    (Γ₀ ⊢ e1.subst σ ≡ e1.subst σ' : A.subst σ) ∧
+    (Γ₀ ⊢ e2.subst σ ≡ e2.subst σ' : A.subst σ) := by
+  induction H generalizing Γ₀ σ σ' with
+  | bvar h _ _ =>
+    exact ⟨W.lookup h, W.lookup h⟩
+  | symm _ ih =>
+    exact ⟨(ih W).2, (ih W).1⟩
+  | trans _ _ ih₁ ih₂ =>
+    exact ⟨(ih₁ W).1, (ih₂ W).2⟩
+  | sort =>
+    exact ⟨.sort, .sort⟩
+  | const hreg hlen _ _ _ =>
+    constructor <;>
+      rw [((henv.closedC hreg).mkInstS).subst_eq .zero] <;>
+      exact .const hreg hlen
+  | @appDF Γ A u B v f f' a a' hA hCod hf ha hB
+      ihA ihCod ihf iha ihB =>
+    have hf' := ihf W
+    have ha' := iha W
+    have hcod : Γ₀ ⊢
+        (B.subst σ.lift).inst (a.subst σ) ≡
+        (B.subst σ.lift).inst (a'.subst σ) : .sort v := by
+      simpa only [SExpr.subst, SExpr.subst_inst] using hB.defeq.subst W.left
+    constructor
+    · simpa only [SExpr.subst, SExpr.subst_inst] using
+        (IsDefEq.appDF hf'.1 ha'.1)
+    · have happ := IsDefEq.appDF hf'.2 ha'.2
+      have happ' := hcod.symm.defeqDF happ
+      simpa only [SExpr.subst, SExpr.subst_inst] using happ'
+  | @lamDF Γ A A' u B v body body' hA hB hB' hBody hBody'
+      ihA ihB ihB' ihBody ihBody' =>
+    have WA := W.lift hA.defeq.hasType.1
+    have WA' := W.lift hA.defeq.hasType.2
+    have hdom := ihA W
+    have hbody := ihBody WA
+    have hbody' := ihBody' WA'
+    constructor
+    · simpa only [SExpr.subst] using
+        (IsDefEq.lamDF hdom.1 hbody.1)
+    · have hlam := IsDefEq.lamDF hdom.2 hbody'.2
+      have hPi : Γ₀ ⊢
+          .forallE (A.subst σ) (B.subst σ.lift) ≡
+          .forallE (A'.subst σ) (B.subst σ.lift) : .sort (.imax u v) :=
+        .forallEDF (hA.defeq.subst W.left)
+          (hB.defeq.subst (W.left.lift IsDefEq.weakCore IsDefEq.bvar))
+      simpa only [SExpr.subst] using hPi.symm.defeqDF hlam
+  | @forallEDF Γ A A' u body body' v hA hBody hBody'
+      ihA ihBody ihBody' =>
+    have hdom := ihA W
+    constructor
+    · simpa only [SExpr.subst] using
+        (IsDefEq.forallEDF hdom.1
+          (ihBody (W.lift hA.defeq.hasType.1)).1)
+    · simpa only [SExpr.subst] using
+        (IsDefEq.forallEDF hdom.2
+          (ihBody' (W.lift hA.defeq.hasType.2)).2)
+  | defeqDF hA _ ihA ihe =>
+    have htype := hA.defeq.subst W.left
+    exact ⟨htype.defeqDF (ihe W).1, htype.defeqDF (ihe W).2⟩
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    exact ⟨(ihApp W).1, (ihInst W).1⟩
+  | eta _ _ ihe ihLam =>
+    exact ⟨(ihLam W).1, (ihe W).1⟩
+  | proofIrrel _ _ _ ihp ihh ihh' =>
+    exact ⟨(ihh W).1, (ihh' W).1⟩
+  | defn hreg hlen _ _ _ _ _ _ _ ihRhs =>
+    constructor
+    · rw [((henv.closedC hreg).mkInstS).subst_eq .zero]
+      exact .const hreg hlen
+    · exact (ihRhs W).1
+  | extra _ _ _ ihLeft ihRight =>
+    exact ⟨(ihLeft W).1, (ihRight W).1⟩
+
+/-- Heterogeneous substitution for the evidence-rich judgment, returned in
+the weak judgment consumed by the logical relation. -/
+theorem IsDefEqStrong.subst (W : Ctx.SubstEq Γ₀ σ σ' Γ)
+    (H : IsDefEqStrong Γ e1 e2 A) :
+    Γ₀ ⊢ e1.subst σ ≡ e2.subst σ' : A.subst σ :=
+  (H.defeq.subst W.left).trans (H.substCongr W).2
+
+/-- A certified local contraction remains certified after weakening.  The
+finite check list is transported pointwise, so downstream reduction rules do
+not need to unpack and rebuild the certificate themselves. -/
+def _root_.Lean4Lean.Pattern.Action.weak' (action : Pattern.Action Γ r e m1 m2 A)
+    (W : Ctx.Lift' ρ Γ Γ') :
+    Pattern.Action Γ' r (e.lift' ρ) m1
+      (fun path => (m2 path).lift' ρ) (A.lift' ρ) := by
+  let dfs' := action.dfs.map fun d =>
+    (d.1.lift' ρ, d.2.1.lift' ρ, d.2.2.lift' ρ)
+  refine {
+    pat := action.pat
+    matched := action.matched.lift'
+    dfs := dfs'
+    defeqs := ?_
+    checked := ?_
+    sound := ?_ }
+  · rw [← Pattern.Check.defeqsS_lift', ← action.defeqs]
+    simp [dfs', Function.comp_def]
+  · intro a b B hab
+    simp only [dfs', List.mem_map] at hab
+    obtain ⟨⟨B₀, a₀, b₀⟩, hab, heq⟩ := hab
+    have hB : B₀.lift' ρ = B := congrArg Prod.fst heq
+    have hab' : (a₀.lift' ρ, b₀.lift' ρ) = (a, b) := congrArg Prod.snd heq
+    have ha : a₀.lift' ρ = a := congrArg Prod.fst hab'
+    have hb : b₀.lift' ρ = b := congrArg Prod.snd hab'
+    subst B
+    subst a
+    subst b
+    exact (action.checked a₀ b₀ B₀ hab).weak' W
+  · simpa only [Pattern.RHS.lift'_applyS] using action.sound.weak' W
+
+/-- Evidence-rich equality is stable under context embeddings.  Constants
+are rebuilt from the semantic environment at the target context, avoiding
+any false assumption that the abstract constructor bundle's SExpr fields are
+syntactically closed; local extension leaves weaken their finite `Action`
+certificate pointwise. -/
+theorem IsDefEqStrong.weak' [Params.Semantic]
+    (W : Ctx.Lift' ρ Γ Γ')
+    (H : IsDefEqStrong Γ e1 e2 A) :
+    IsDefEqStrong Γ' (e1.lift' ρ) (e2.lift' ρ) (A.lift' ρ) := by
+  induction H generalizing ρ Γ' with
+  | bvar h _ ihA => exact .bvar (h.weak' W) (ihA W)
+  | symm _ ih => exact (ih W).symm
+  | trans _ _ ih1 ih2 => exact (ih1 W).trans (ih2 W)
+  | sort => exact .sort
+  | @const c ci Γ ls u hreg hlen hTy F hF hDef ihTy ihF ihDef =>
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero]
+    have hTy' := ihTy W
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero] at hTy'
+    let F' : ∀ cl, CtorBundle c cl := fun cl =>
+      (Params.Semantic.ctor (ls := ls) (Γ := Γ') hreg hlen cl).1
+    have hF' : ∀ cl, IsDefEqStrong Γ'
+        (SExpr.mkInst ls ci.type) ((F' cl).rhs ls) (.sort (F' cl).u) := by
+      intro cl
+      exact (Params.Semantic.ctor (ls := ls) (Γ := Γ') hreg hlen cl).2
+    have hDef' : ∀ {r : (Pattern.const c).RHS × (Pattern.const c).Check},
+        Params.Pat (.const c) r →
+        IsDefEqStrong Γ' (r.1.applyS ls Empty.elim) (.const c ls)
+          (SExpr.mkInst ls ci.type) := by
+      intro r hpat
+      obtain ⟨value, closed, hr, hdef⟩ := Params.Semantic.defn hpat
+      subst r
+      simpa only [Pattern.RHS.applyS] using
+        (hdef hreg hlen : IsDefEqStrong Γ'
+          (.const c ls) (SExpr.mkInst ls value)
+          (SExpr.mkInst ls ci.type)).symm
+    exact .const hreg hlen hTy' F' hF' hDef'
+  | appDF _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    have hResult := ihResult W
+    rw [SExpr.lift'_inst_hi, SExpr.lift'_inst_hi] at hResult
+    exact SExpr.lift'_inst_hi .. ▸
+      .appDF (ihA W) (ihCod W.cons) (ihf W) (iha W) hResult
+  | lamDF _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    exact .lamDF (ihA W) (ihB W.cons) (ihB' W.cons)
+      (ihBody W.cons) (ihBody' W.cons)
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    exact .forallEDF (ihA W) (ihBody W.cons) (ihBody' W.cons)
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA W) (ihe W)
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    have hApp := ihApp W
+    have hInst := ihInst W
+    simp only [SExpr.lift'_inst_hi] at hApp hInst
+    rw [SExpr.lift'_inst_hi, SExpr.lift'_inst_hi]
+    exact .beta (ihBody W.cons) (ihArg W) hApp hInst
+  | @eta Γ e A B hTerm hLam ihTerm ihLam =>
+    have hLam' : IsDefEqStrong Γ'
+        (.lam (A.lift' ρ) ((e.lift' ρ).lift.app (.bvar 0)))
+        (.lam (A.lift' ρ) ((e.lift' ρ).lift.app (.bvar 0)))
+        (.forallE (A.lift' ρ) (B.lift' ρ.cons)) := by
+      simpa [SExpr.lift, ← SExpr.lift'_comp] using ihLam W
+    simpa [SExpr.lift, ← SExpr.lift'_comp] using
+      IsDefEqStrong.eta (ihTerm W) hLam'
+  | proofIrrel _ _ _ ihProp ihLeft ihRight =>
+    exact .proofIrrel (ihProp W) (ihLeft W) (ihRight W)
+  | @defn c ci Γ ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero]
+    have hTy' := ihTy W
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero] at hTy'
+    let F' : ∀ cl, CtorBundle c cl := fun cl =>
+      (Params.Semantic.ctor (ls := ls) (Γ := Γ') hreg hlen cl).1
+    have hF' : ∀ cl, IsDefEqStrong Γ'
+        (SExpr.mkInst ls ci.type) ((F' cl).rhs ls) (.sort (F' cl).u) := by
+      intro cl
+      exact (Params.Semantic.ctor (ls := ls) (Γ := Γ') hreg hlen cl).2
+    have hempty :
+        (fun path : Empty => (Empty.elim path : SExpr).lift' ρ) = Empty.elim := by
+      funext path
+      exact nomatch path
+    have hAction := action.weak' W
+    simp only [SExpr.lift'] at hAction
+    rw [hempty, ((Params.henv.closedC hreg).mkInstS).lift'_eq .zero] at hAction
+    have hRhs' := ihRhs W
+    rw [Pattern.RHS.lift'_applyS] at hRhs'
+    rw [hempty, ((Params.henv.closedC hreg).mkInstS).lift'_eq .zero] at hRhs'
+    rw [Pattern.RHS.lift'_applyS, hempty]
+    exact IsDefEqStrong.defn hreg hlen hTy' F' hF' hAction hRhs'
+  | extra action _ _ ihLeft ihRight =>
+    have hRight := ihRight W
+    rw [Pattern.RHS.lift'_applyS] at hRight
+    simpa only [Pattern.RHS.lift'_applyS] using
+      IsDefEqStrong.extra (action.weak' W) (ihLeft W) hRight
+
+/-- A certified local contraction remains certified after a genuinely typed
+substitution.  In particular, generated-rule checks and the final local
+equality are transported by the same weak-defeq substitution theorem. -/
+def _root_.Lean4Lean.Pattern.Action.subst
+    (action : Pattern.Action Γ r e m1 m2 A)
+    (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Δ σ Γ) :
+    Pattern.Action Δ r (e.subst σ) m1
+      (fun path => (m2 path).subst σ) (A.subst σ) := by
+  let dfs' := action.dfs.map fun d =>
+    (d.1.subst σ, d.2.1.subst σ, d.2.2.subst σ)
+  refine {
+    pat := action.pat
+    matched := action.matched.subst
+    dfs := dfs'
+    defeqs := ?_
+    checked := ?_
+    sound := ?_ }
+  · rw [← Pattern.Check.defeqsS_subst, ← action.defeqs]
+    simp [dfs', Function.comp_def]
+  · intro a b B hab
+    simp only [dfs', List.mem_map] at hab
+    obtain ⟨⟨B₀, a₀, b₀⟩, hab, heq⟩ := hab
+    have hB : B₀.subst σ = B := congrArg Prod.fst heq
+    have hab' : (a₀.subst σ, b₀.subst σ) = (a, b) := congrArg Prod.snd heq
+    have ha : a₀.subst σ = a := congrArg Prod.fst hab'
+    have hb : b₀.subst σ = b := congrArg Prod.snd hab'
+    subst B
+    subst a
+    subst b
+    exact (action.checked a₀ b₀ B₀ hab).subst W
+  · simpa only [Pattern.RHS.subst_applyS] using action.sound.subst W
+
+/-- A lookup remains typable when one older context entry is replaced by a
+definitionally equal type.  The distinguished lookup is the only case that
+needs conversion; entries above it are weakened and entries below it are
+unchanged. -/
+theorem Lookup.defeqDF_l' (h1 : Γ ⊢ A ≡ A' : .sort u)
+    (h : Lookup (Δ ++ A :: Γ) i B) : Δ ++ A' :: Γ ⊢ .bvar i : B := by
+  induction Δ generalizing i B with
+  | nil =>
+    cases h with
+    | zero =>
+      exact (h1.weak' (.skip .refl)).symm.defeqDF (.bvar .zero)
+    | succ h => exact .bvar (.succ h)
+  | cons D Δ ih =>
+    cases h with
+    | zero => exact .bvar .zero
+    | succ h =>
+      simpa only [List.cons_append, SExpr.lift, SExpr.lift', Lift.liftVar] using
+        (ih h).weak' (.skip .refl)
+
 theorem IsDefEq.defeqDF_l' (h1 : Γ ⊢ A ≡ A' : .sort u)
     (h2 : Δ++A::Γ ⊢ e1 ≡ e2 : B) : Δ++A'::Γ ⊢ e1 ≡ e2 : B := by
-  sorry
+  generalize hctx : Δ ++ A :: Γ = Γ₁ at h2
+  induction h2 generalizing Δ with
+  | bvar h =>
+    rw [← hctx] at h
+    exact h.defeqDF_l' h1
+  | symm _ ih => exact (ih hctx).symm
+  | trans _ _ ih₁ ih₂ => exact (ih₁ hctx).trans (ih₂ hctx)
+  | sort => exact .sort
+  | const hreg hlen => exact .const hreg hlen
+  | appDF _ _ ihf iha => exact .appDF (ihf hctx) (iha hctx)
+  | lamDF _ _ ihA ihBody =>
+    exact .lamDF (ihA hctx)
+      (ihBody (Δ := _ :: Δ) (congrArg (List.cons _) hctx))
+  | forallEDF _ _ ihA ihBody =>
+    exact .forallEDF (ihA hctx)
+      (ihBody (Δ := _ :: Δ) (congrArg (List.cons _) hctx))
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA hctx) (ihe hctx)
+  | beta _ _ ihBody ihArg =>
+    exact .beta
+      (ihBody (Δ := _ :: Δ) (congrArg (List.cons _) hctx)) (ihArg hctx)
+  | eta _ ih => exact .eta (ih hctx)
+  | proofIrrel _ _ _ ihp ihh ihh' =>
+    exact .proofIrrel (ihp hctx) (ihh hctx) (ihh' hctx)
+  | extra hreg hlen => exact .extra hreg hlen
 
 theorem IsDefEq.defeqDF_l (h1 : Γ ⊢ A ≡ A' : .sort u)
     (h2 : A::Γ ⊢ e1 ≡ e2 : B) : A'::Γ ⊢ e1 ≡ e2 : B :=
@@ -831,6 +3733,260 @@ theorem IsDefEq.defeqDF_l (h1 : Γ ⊢ A ≡ A' : .sort u)
 theorem HasType.defeq_l (h1 : Γ ⊢ A ≡ A' : .sort u)
     (h2 : A::Γ ⊢ e : B) : A'::Γ ⊢ e : B := h1.defeqDF_l h2
 
+/-! ### Heterogeneous type-equality paths
+
+Relocated here from `Lean4Lean/Experimental/ShapeLogRel.lean` on 2026-08-15.
+The whole API depends only on `IsDefEq.defeqDF`, `IsDefEq.defeqDF_l` (:3588),
+`IsDefEq.subst` (:3255) and `Ctx.Subst` (:3025) — every one of them an SExpr
+notion — so it belongs beside them rather than inside the logical-relation
+development.  Moving it up is what lets the evidence-rich inversion suite
+below state its conclusion: each inverter returns the *path* from the
+subject's own type to the declared type.
+
+`TypeDefEqPath.collapse` deliberately stays in `ShapeLogRel.lean`, beside
+`LogRel.RawTypeUniq`, which is its one extra input and is the whole of raw
+type uniqueness. -/
+
+/-- A nonempty path of ordinary type equalities.  Adjacent edges may type
+their shared endpoint in different universes; retaining the path avoids the
+unsound heterogeneous transitivity rule while still supporting every
+conversion operation one edge at a time. -/
+inductive TypeDefEqPath (Γ : List SExpr) : SExpr → SExpr → SLevel → Prop where
+  | single : IsDefEq Γ A B (.sort u) → TypeDefEqPath Γ A B u
+  | trans : TypeDefEqPath Γ A B u → TypeDefEqPath Γ B C v →
+      TypeDefEqPath Γ A C u
+
+theorem TypeDefEqPath.leftType
+    (H : TypeDefEqPath Γ A B u) : IsDefEq Γ A A (.sort u) := by
+  induction H with
+  | single h => exact h.hasType.1
+  | trans _ _ ih _ => exact ih
+
+theorem TypeDefEqPath.rightType
+    (H : TypeDefEqPath Γ A B u) : ∃ v, IsDefEq Γ B B (.sort v) := by
+  induction H with
+  | single h => exact ⟨_, h.hasType.2⟩
+  | trans _ _ _ ih => exact ih
+
+theorem TypeDefEqPath.left
+    (H : TypeDefEqPath Γ A B u) : TypeDefEqPath Γ A A u :=
+  .single H.leftType
+
+theorem TypeDefEqPath.right
+    (H : TypeDefEqPath Γ A B u) : ∃ v, TypeDefEqPath Γ B B v := by
+  obtain ⟨v, hB⟩ := H.rightType
+  exact ⟨v, .single hB⟩
+
+theorem TypeDefEqPath.symm
+    (H : TypeDefEqPath Γ A B u) : ∃ v, TypeDefEqPath Γ B A v := by
+  induction H with
+  | single h => exact ⟨_, .single h.symm⟩
+  | trans _ _ ih₁ ih₂ =>
+    obtain ⟨v₂, h₂⟩ := ih₂
+    obtain ⟨_, h₁⟩ := ih₁
+    exact ⟨v₂, .trans h₂ h₁⟩
+
+/-- Transport a term equality through a path of type conversions. -/
+theorem TypeDefEqPath.defeqDF
+    (H : TypeDefEqPath Γ A B u)
+    (h : IsDefEq Γ e₁ e₂ A) : IsDefEq Γ e₁ e₂ B := by
+  induction H with
+  | single hAB => exact hAB.defeqDF h
+  | trans _ _ ih₁ ih₂ => exact ih₂ (ih₁ h)
+
+/-- Replace the newest context entry along a path, one ordinary conversion
+at a time. -/
+theorem TypeDefEqPath.defeqDF_l
+    (H : TypeDefEqPath Γ A B u)
+    (h : IsDefEq (A :: Γ) e₁ e₂ C) : IsDefEq (B :: Γ) e₁ e₂ C := by
+  induction H with
+  | single hAB => exact hAB.defeqDF_l h
+  | trans _ _ ih₁ ih₂ => exact ih₂ (ih₁ h)
+
+/-- Transport every edge of a type-equality path into a converted binder
+context. -/
+theorem TypeDefEqPath.defeqDF_l_path
+    (H : TypeDefEqPath Γ A B u)
+    (P : TypeDefEqPath (A :: Γ) C D v) :
+    TypeDefEqPath (B :: Γ) C D v := by
+  induction P with
+  | single h => exact .single (H.defeqDF_l h)
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+
+/-- Substitute every ordinary edge of a heterogeneous type path. -/
+theorem TypeDefEqPath.subst
+    (H : TypeDefEqPath Γ A B u)
+    (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Γ₀ σ Γ) :
+    TypeDefEqPath Γ₀ (A.subst σ) (B.subst σ) u := by
+  induction H with
+  | single h => exact .single (h.subst W)
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+
+/-! ### Evidence-rich inversion, with the declared-type path
+
+The three theorems below extend `IsDefEqStrong.forallE_inv'` (:2284) to the
+application and lambda shapes, and strengthen the Pi case, in one respect:
+each also returns the `TypeDefEqPath` from the subject's **own** type to the
+declared type `V`.  That is their whole novelty over Theory's
+`VEnv.HasType.app_inv` / `.lam_inv`, and it is what removes the
+`IsDefEq.trans_l` / `IsDefEqU.uniqU` fixups the Theory proofs have to spend:
+a consumer that receives the path never has to re-derive the relation between
+the two types, and in particular never charges type uniqueness to do so.
+
+All three are structural in exactly the style of `forallE_inv'` — every
+extension leaf of `IsDefEqStrong` carries its endpoint typings — so none of
+them appeals to weak type uniqueness, to Church–Rosser, or to
+`IsDefEq.strong`.  Measured `[propext, Quot.sound]` in
+`plans/probes/probeR13-loop.lean`. -/
+
+/-- Application inversion, evidence-rich.  Unlike Theory's
+`VEnv.HasType.app_inv` this also returns the *path* from the application's own
+result type `B.inst a` to the declared type `V`, which is what makes the
+ordinary `trans_l` / type-uniqueness fixup unnecessary downstream. -/
+theorem IsDefEqStrong.app_inv'
+    (H : IsDefEqStrong Γ e₁ e₂ V)
+    (eq : e₁ = .app f a ∨ e₂ = .app f a) :
+    ∃ A B w, IsDefEqStrong Γ f f (.forallE A B) ∧ IsDefEqStrong Γ a a A ∧
+      TypeDefEqPath Γ (B.inst a) V w := by
+  induction H generalizing f a with
+  | bvar => nomatch eq
+  | symm _ ih => exact ih eq.symm
+  | trans _ _ ih₁ ih₂ =>
+    obtain eq | eq := eq
+    · exact ih₁ (.inl eq)
+    · exact ih₂ (.inr eq)
+  | sort => nomatch eq
+  | const => nomatch eq
+  | @appDF _ A u B v _ _ _ _ _ _ hf ha hResult _ _ _ _ _ =>
+    obtain ⟨⟨⟩⟩ | ⟨⟨⟩⟩ := eq
+    · exact ⟨A, B, v, hf.hasType.1, ha.hasType.1, .single hResult.hasType.1.defeq⟩
+    · exact ⟨A, B, v, hf.hasType.2, ha.hasType.2, .single hResult.symm.defeq⟩
+  | lamDF => nomatch eq
+  | forallEDF => nomatch eq
+  | defeqDF hType _ _ ih =>
+    obtain ⟨A, B, w, h1, h2, P⟩ := ih eq
+    exact ⟨A, B, w, h1, h2, P.trans (.single hType.defeq)⟩
+  | beta _ _ _ _ _ _ ihApp ihInst =>
+    obtain eq | eq := eq
+    · exact ihApp (.inl eq)
+    · exact ihInst (.inl eq)
+  | eta _ _ ihTerm _ =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihTerm (.inl eq)
+  | proofIrrel _ _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+  | defn _ _ _ _ _ _ _ _ _ ihRhs =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihRhs (.inl eq)
+  | extra _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+
+/-- Lambda inversion, evidence-rich.  Unlike Theory's `VEnv.HasType.lam_inv`
+this returns the abstraction's *own* Pi type `.forallE A B` together with the
+path from it to the declared type `V`, so no consumer has to reconcile the two
+by type uniqueness. -/
+theorem IsDefEqStrong.lam_inv'
+    (H : IsDefEqStrong Γ e₁ e₂ V)
+    (eq : e₁ = .lam A body ∨ e₂ = .lam A body) :
+    ∃ B u v w, IsDefEqStrong Γ A A (.sort u) ∧
+      IsDefEqStrong (A :: Γ) B B (.sort v) ∧
+      IsDefEqStrong (A :: Γ) body body B ∧
+      TypeDefEqPath Γ (.forallE A B) V w := by
+  induction H generalizing A body with
+  | bvar => nomatch eq
+  | symm _ ih => exact ih eq.symm
+  | trans _ _ ih₁ ih₂ =>
+    obtain eq | eq := eq
+    · exact ih₁ (.inl eq)
+    · exact ih₂ (.inr eq)
+  | sort => nomatch eq
+  | const => nomatch eq
+  | appDF => nomatch eq
+  | @lamDF _ A₀ A₀' u B v _ _ hA hB hB' hbody hbody' _ _ _ _ _ =>
+    obtain ⟨⟨⟩⟩ | ⟨⟨⟩⟩ := eq
+    · exact ⟨B, u, v, _, hA.hasType.1, hB, hbody.hasType.1,
+        .single (IsDefEqStrong.forallEDF hA.hasType.1 hB hB).defeq⟩
+    · exact ⟨B, u, v, _, hA.hasType.2, hB', hbody'.hasType.2,
+        .single (IsDefEqStrong.forallEDF hA.symm hB' hB).defeq⟩
+  | forallEDF => nomatch eq
+  | defeqDF hType _ _ ih =>
+    obtain ⟨B, u, v, w, h1, h2, h3, P⟩ := ih eq
+    exact ⟨B, u, v, w, h1, h2, h3, P.trans (.single hType.defeq)⟩
+  | beta _ _ _ _ _ _ _ ihInst =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihInst (.inl eq)
+  | eta _ _ ihTerm ihLam =>
+    obtain eq | eq := eq
+    · exact ihLam (.inl eq)
+    · exact ihTerm (.inl eq)
+  | proofIrrel _ _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+  | defn _ _ _ _ _ _ _ _ _ ihRhs =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihRhs (.inl eq)
+  | extra _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+
+/-- `IsDefEqStrong.forallE_inv'` (:2284) with the declared-type path added, in
+the same structural style: the Pi's own type `.sort (.imax u v)` is returned
+together with the path from it to `V`. -/
+theorem IsDefEqStrong.forallE_inv_path
+    (H : IsDefEqStrong Γ e₁ e₂ V)
+    (eq : e₁ = .forallE A B ∨ e₂ = .forallE A B) :
+    ∃ u v w, IsDefEqStrong Γ A A (.sort u) ∧
+      IsDefEqStrong (A :: Γ) B B (.sort v) ∧
+      TypeDefEqPath Γ (.sort (.imax u v)) V w := by
+  induction H generalizing A B with
+  | bvar => nomatch eq
+  | symm _ ih => exact ih eq.symm
+  | trans _ _ ih₁ ih₂ =>
+    obtain eq | eq := eq
+    · exact ih₁ (.inl eq)
+    · exact ih₂ (.inr eq)
+  | sort => nomatch eq
+  | const => nomatch eq
+  | appDF => nomatch eq
+  | lamDF => nomatch eq
+  | forallEDF hA hBody hBody' _ _ _ =>
+    obtain ⟨⟨⟩⟩ | ⟨⟨⟩⟩ := eq
+    · exact ⟨_, _, _, hA.hasType.1, hBody.hasType.1, .single .sort⟩
+    · exact ⟨_, _, _, hA.hasType.2, hBody'.hasType.2, .single .sort⟩
+  | defeqDF hType _ _ ih =>
+    obtain ⟨u, v, w, h1, h2, P⟩ := ih eq
+    exact ⟨u, v, w, h1, h2, P.trans (.single hType.defeq)⟩
+  | beta _ _ _ _ _ _ _ ihInst =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihInst (.inl eq)
+  | eta _ _ ihTerm _ =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihTerm (.inl eq)
+  | proofIrrel _ _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+  | defn _ _ _ _ _ _ _ _ _ ihRhs =>
+    obtain eq | eq := eq
+    · nomatch eq
+    · exact ihRhs (.inl eq)
+  | extra _ _ _ ihLeft ihRight =>
+    obtain eq | eq := eq
+    · exact ihLeft (.inl eq)
+    · exact ihRight (.inr eq)
+
 variable (DefEq : List SExpr → SExpr → SExpr → SExpr → Prop) in
 structure WithLift (Γ : List SExpr) (e1 e2 A : SExpr) : Prop where
   defeq' {{Δ ρ e1' e2' A'}} : Ctx.Lift' ρ Δ Γ →
@@ -882,8 +4038,23 @@ theorem WithLift.weak'
 theorem IsDefEqLift.weak' : Ctx.Lift' ρ Γ Δ → Γ ⊢ e1 ≡ e2 :↑ A →
     Δ ⊢ e1.lift' ρ ≡ e2.lift' ρ :↑ A.lift' ρ := WithLift.weak' IsDefEq.weak'
 
-theorem IsDefEqLift.subst : Ctx.Subst HasType Δ σ Γ → Γ ⊢ e1 ≡ e2 :↑ A →
-    Δ ⊢ e1.subst σ ≡ e2.subst σ :↑ A.subst σ := sorry
+/-- A lowering-stable equality may always be instantiated as an ordinary
+typed equality.  This is the sound substitution fact that does not claim the
+result still has universal inverse-weakening closure. -/
+theorem IsDefEqLift.substDefEq
+    (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Δ σ Γ)
+    (H : Γ ⊢ e1 ≡ e2 :↑ A) :
+    Δ ⊢ e1.subst σ ≡ e2.subst σ : A.subst σ :=
+  (H.defeq' .refl SExpr.lift'_refl.symm SExpr.lift'_refl.symm
+    SExpr.lift'_refl.symm).subst W
+
+/- There is deliberately no `IsDefEqLift.subst` concluding at `:↑`. The
+former statement quantified over the free section relation `HasType`, so
+instantiating it at the trivial relation claimed lift-stability of `≡ :↑`
+under arbitrary substitutions, which is false. `substDefEq` above is the
+sound instantiation-to-ordinary-equality form; a `:↑`-valued conclusion
+would additionally need a `Ctx.Subst`-vs-`Ctx.Lift'` commutation witness
+in the premise, which no current consumer requires. -/
 
 theorem WithLift.weak'_inv (W : Ctx.Lift' ρ Γ Δ)
     (H : WithLift DefEq Δ (e1.lift' ρ) (e2.lift' ρ) (A.lift' ρ)) : WithLift DefEq Γ e1 e2 A where
@@ -943,30 +4114,92 @@ theorem IsDefEq.defeqDFC' (h1 : IsDefEqCtx Γ₀ Γ₁ Γ₂)
 theorem IsDefEq.defeqDFC (h1 : IsDefEqCtx Γ₀ Γ₁ Γ₂)
     (h2 : Γ₁ ⊢ e₁ ≡ e₂ : A) : Γ₂ ⊢ e₁ ≡ e₂ : A := .defeqDFC' (Δ := []) h1 h2
 
+omit [Params] in theorem Subpattern.varN_constS (H : Subpattern p (.varN (.const c) n)) :
+    ∃ n, p = .varN (.const c) n := by
+  generalize eq : Pattern.varN (.const c) n = p' at H
+  induction H generalizing n with
+  | refl => exact ⟨_, eq.symm⟩
+  | appL | appR => cases n <;> cases eq
+  | varL _ ih => cases n <;> cases eq; exact ih rfl
+
+theorem Params.simple_appS (H : Pat p r) (h : Subpattern (.app p₁ p₂) p) :
+    .app p₁ p₂ = p := by
+  obtain ⟨_|_, rfl⟩ := Params.pat_simple H <;> cases h
+  · rfl
+  · obtain ⟨_|_, ⟨⟩⟩ := Subpattern.varN_constS ‹_›
+  · obtain ⟨_|_, ⟨⟩⟩ := Subpattern.varN_constS ‹_›
+
+/-- A function spine whose next argument is inspected by a registered
+pattern.  This is the SExpr counterpart of Theory's `VEnv.IsMajorPremise`;
+it is what permits weak-head reduction inside an iota major premise before
+the proof-carrying pattern contraction fires. -/
+def IsMajorPremise (e : SExpr) :=
+  ∃ p, (∃ r, Pat p r) ∧ ∃ p₁ p₂, Subpattern (.app p₁ p₂) p ∧
+    ∃ m1 m2, p₁.MatchesS e m1 m2
+
+theorem IsMajorPremise.lift' {e : SExpr} {ρ : Lift} :
+    IsMajorPremise (e.lift' ρ) ↔ IsMajorPremise e := by
+  constructor <;> intro ⟨_, h1, _, _, h2, _, _, h3⟩
+  · obtain ⟨_, h4, _⟩ := Pattern.matchesS_lift'.1 h3
+    exact ⟨_, h1, _, _, h2, _, _, h4⟩
+  · exact ⟨_, h1, _, _, h2, _, _, h3.lift'⟩
+
+theorem IsMajorPremise.subst {e : SExpr} {σ : Subst} :
+    IsMajorPremise e → IsMajorPremise (e.subst σ)
+  | ⟨_, h1, _, _, h2, _, _, h3⟩ =>
+    ⟨_, h1, _, _, h2, _, _, h3.subst⟩
+
+theorem IsMajorPremise.lam : ¬IsMajorPremise (.lam A e) := nofun
+
+theorem Params.pat_not_varS : ¬Pat (.var p) r := (nomatch Params.pat_simple ·)
+
 scoped notation:65 Γ " ⊢ " e1 " ⤳ " e2:36 => WHRed Γ e1 e2
 inductive WHRed (Γ : List SExpr) : SExpr → SExpr → Prop where
   | app : Γ ⊢ f ⤳ f' → Γ ⊢ .app f a ⤳ .app f' a
+  | major : IsMajorPremise f → Γ ⊢ a ⤳ a' → Γ ⊢ .app f a ⤳ .app f a'
   | beta : Γ ⊢ .app (.lam A e) a ⤳ e.inst a
-  | extra : Pat p r → p.MatchesS e m1 m2 → (dfs : List _).map (·.2) = r.2.defeqsS m1 m2 →
-    (∀ a b A, (A, a, b) ∈ dfs → Γ ⊢ a ≡ b : A) → Γ ⊢ e ⤳ r.1.applyS m1 m2
+  /-- A local extension contraction consumes the same finite certificate as
+  strong equality; pattern membership alone is not operational evidence. -/
+  | extra : Pattern.Action Γ r e m1 m2 A →
+    Γ ⊢ e ⤳ r.1.applyS m1 m2
 
-theorem WHRed.subst (W : Ctx.Subst HasType Δ σ Γ) :
+theorem WHRed.subst
+    (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Δ σ Γ) :
     Γ ⊢ e1 ⤳ e2 → Δ ⊢ e1.subst σ ⤳ e2.subst σ
   | .app h1 => .app (h1.subst W)
+  | .major h1 h2 => .major h1.subst (h2.subst W)
   | .beta => subst_inst ▸ .beta
-  | .extra h1 h2 h3 h4 => sorry
+  | @extra _ Γ p r e m1 m2 A action => by
+    rw [Pattern.RHS.subst_applyS]
+    exact .extra (action.subst W)
 
 theorem WHRed.weak' (W : Ctx.Lift' ρ Γ Γ') :
     Γ ⊢ e1 ⤳ e2 → Γ' ⊢ e1.lift' ρ ⤳ e2.lift' ρ
   | .app h1 => .app (h1.weak' W)
+  | .major h1 h2 => .major (IsMajorPremise.lift'.2 h1) (h2.weak' W)
   | .beta => by rw [SExpr.lift'_inst_hi]; exact .beta
-  | .extra h1 h2 h3 h4 => sorry
-
+  | @extra _ Γ p r e m1 m2 A action => by
+    rw [Pattern.RHS.lift'_applyS]
+    exact .extra (action.weak' W)
+
+/-- Inverse weakening for one weak-head step. The `.extra` case is
+deferred (off the L4L-16 gate path; consumed only through the
+`WHRedS.weakU_inv` mirror, whose live consumers are `InferType.weakU_inv`
+below and `LRIsType.weak'` in `Experimental/LogRel.lean`): it needs to
+lower the two `IsDefEq` fields of the matched `Pattern.Action`, which
+requires either a context-WF-conditioned `IsDefEq` inverse weakening or
+restating `Action.checked`/`sound` at `:↑`. See
+plans/l4l-16-completion-plan.md §16B′. -/
 theorem WHRed.weakU_inv (W : Ctx.Lift' ρ Γ Γ') (H : Γ' ⊢ e1.lift' ρ ⤳ e2') :
     ∃ e2, e2' = e2.lift' ρ ∧ Γ ⊢ e1 ⤳ e2 := by
   generalize he : e1.lift' ρ = e1' at H
   induction H generalizing e1 with
   | app h1 ih => let .app .. := e1; cases he; obtain ⟨_, rfl, a1⟩ := ih rfl; exact ⟨_, rfl, .app a1⟩
+  | major h1 h2 ih =>
+    let .app .. := e1
+    cases he
+    obtain ⟨_, rfl, a1⟩ := ih rfl
+    exact ⟨_, rfl, .major (IsMajorPremise.lift'.1 h1) a1⟩
   | beta =>
     let .app e1 _ := e1; let .lam .. := e1; cases he
     simp [← SExpr.lift'_inst_hi, SExpr.lift'_inj]; exact .beta
@@ -974,37 +4207,225 @@ theorem WHRed.weakU_inv (W : Ctx.Lift' ρ Γ Γ') (H : Γ' ⊢ e1.lift' ρ ⤳ e
 
 def WHNF (Γ : List SExpr) (e : SExpr) := ∀ e', ¬Γ ⊢ e ⤳ e'
 
-theorem WHNF.lam : WHNF Γ (.lam A e) := nofun
-theorem WHNF.sort : WHNF Γ (.sort A) := nofun
-theorem WHNF.forallE : WHNF Γ (.forallE A B) := nofun
+theorem WHNF.lam : WHNF Γ (.lam A e) := by
+  intro _ hred
+  cases hred with
+  | extra action => nomatch action.matched
+
+theorem WHNF.sort : WHNF Γ (.sort A) := by
+  intro _ hred
+  cases hred with
+  | extra action => nomatch action.matched
+
+theorem WHNF.forallE : WHNF Γ (.forallE A B) := by
+  intro _ hred
+  cases hred with
+  | extra action => nomatch action.matched
+
+theorem WHNF.subpattern
+    (h1 : Params.Pat p r) (h2 : Subpattern p₁ p) (h3 : p₁ ≠ p)
+    (h4 : p₁.MatchesS e m1 m2) : WHNF Γ e := by
+  intro _ H2
+  obtain ⟨c, n, rfl⟩ : ∃ c n, p₁ = .varN (.const c) n := by
+    obtain ⟨_|_, rfl⟩ := Params.pat_simple h1 <;> cases h2 <;>
+      first | cases h3 rfl | exact ⟨_, Subpattern.varN_constS ‹_›⟩
+  have hn : ∀ r, ¬Params.Pat (.const c) r := fun _ h => by
+    cases (Params.pat_uniq h1 h (.trans (.varN .refl) h2) (Pattern.inter_self _)).1
+    exact h3.symm (h2.antisymm (.varN .refl))
+  clear h3
+  induction H2 generalizing n with
+  | app r1 ih =>
+    let n+1 := n
+    let .var h4 := h4
+    exact ih _ (.trans (.varL .refl) h2) h4
+  | major r1 r2 ih =>
+    let n+1 := n
+    let .var h4 := h4
+    let ⟨p', ⟨_, h1'⟩, p₁', p₂', h2', _, _, h3'⟩ := r1
+    cases Params.simple_appS h1' h2'
+    obtain ⟨⟨_, n, _⟩ | _, rfl⟩ := Params.pat_simple h1 <;>
+      [skip; cases n <;> cases h2]
+    have ⟨_, _, _, a1, _a2⟩ := Pattern.matchesS_inter.1
+      ⟨⟨_, _, h3'⟩, ⟨_, _, h4⟩⟩
+    cases h2 with
+    | appL h2 =>
+      cases (Params.pat_app_l_uniq h1 h1' .refl .refl h2).symm.trans a1
+    | appR h2 =>
+      cases (Params.pat_app_uniq h1' h1 .refl .refl .refl
+        (.trans (.varL .refl) h2)).symm.trans a1
+  | beta => generalize Pattern.varN .. = p' at m1 m2 h4; nomatch h4
+  | extra action =>
+    have ⟨_, _, _, a1, a2⟩ := Pattern.matchesS_inter.1
+      ⟨⟨_, _, action.matched⟩, ⟨_, _, h4⟩⟩
+    obtain ⟨⟨_, major, _, _⟩ | _, rfl⟩ := Params.pat_simple h1 <;>
+      [skip; cases n <;> cases h2]
+    obtain ⟨rfl, eq, _⟩ := Params.pat_uniq h1 action.pat h2 a1
+    cases n <;> cases eq
+    exact hn _ h1
+
+theorem IsMajorPremise.whnf : IsMajorPremise e → WHNF Γ e := by
+  rintro ⟨p, ⟨_, h1⟩, p₁, p₂, h2, _, _, h3⟩
+  refine .subpattern h1 (.trans (.appL .refl) h2) ?_ h3
+  rintro rfl
+  cases h2.antisymm (.appL .refl)
+
+omit [Params] in
+/-- Descend a pattern's arity chain to its head constant's classification.
+With the registered defaults (`top := true`, `extra := 0`) this says every
+registered pattern's head classifies as a symbol of the pattern's arity. -/
+theorem _root_.Lean4Lean.Pattern.WF.arity_head
+    {cl : Name → Option Classification} {c : Name} {k : Nat} {p : Pattern}
+    (H : Arity (.const c) k p) :
+    ∀ {top : Bool} {n : Nat}, p.WF cl top n →
+      cl c = some (if top then .symb (k + n) else .ctor (k + n)) := by
+  induction H with
+  | refl => intro top n h; simp only [Nat.zero_add]; exact h
+  | app _ ih =>
+    intro top n h
+    simpa only [Nat.succ_add, Nat.add_succ] using ih h.1
+  | var _ ih =>
+    intro top n h
+    simpa only [Nat.succ_add, Nat.add_succ] using ih h
+
+/-- Constant-headed application spines decompose uniquely. -/
+theorem spine_inj :
+    ∀ (args args' : List SExpr) {c c' : Name} {ls ls' : List SLevel},
+      args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) =
+        args'.foldr (fun (a f : SExpr) => f.app a) (.const c' ls') →
+      c = c' ∧ ls = ls' ∧ args = args'
+  | [], [], _, _, _, _, h => by cases h; exact ⟨rfl, rfl, rfl⟩
+  | [], _ :: _, _, _, _, _, h => by cases h
+  | _ :: _, [], _, _, _, _, h => by cases h
+  | _ :: args, _ :: args', _, _, _, _, h => by
+    injection h with h1 h2
+    obtain ⟨rfl, rfl, rfl⟩ := spine_inj args args' h1
+    cases h2
+    exact ⟨rfl, rfl, rfl⟩
+
+/-- The subject of any registered-pattern match is a constant-headed spine
+whose head classifies as a symbol of the spine's length. -/
+theorem Params.matchesS_symb_head {p : Pattern} {r} {e : SExpr}
+    {m1 : List SLevel} {m2 : p.Path → SExpr}
+    (h1 : Params.Pat p r) (h2 : p.MatchesS e m1 m2) :
+    ∃ (c' : Name) (ls' : List SLevel) (args' : List SExpr),
+      e = args'.foldr (fun (a f : SExpr) => f.app a) (.const c' ls') ∧
+      Params.classify c' = some (.symb args'.length) := by
+  obtain ⟨c', ls', args', rfl, har⟩ := h2.head_spine
+  refine ⟨c', ls', args', rfl, ?_⟩
+  simpa using Pattern.WF.arity_head har (Params.pat_wf h1)
+
+/-- A fully applied spine headed by a classified constructor is weak-head
+normal: registered pattern heads classify as symbols, so no pattern matches
+the spine or any prefix, no prefix is a major premise, and no prefix is a
+lambda. -/
+theorem WHNF.ctorSpine {c : Name} {k : Nat} {ls : List SLevel}
+    (hcl : Params.classify c = some (.ctor k)) (args : List SExpr) :
+    WHNF Γ (args.foldr (fun (a f : SExpr) => f.app a) (.const c ls)) := by
+  induction args with
+  | nil =>
+    intro e' hred
+    cases hred with
+    | extra action =>
+      obtain ⟨c', ls', args', heq, hsymb⟩ :=
+        Params.matchesS_symb_head action.pat action.matched
+      obtain ⟨rfl, -, rfl⟩ := spine_inj [] args' heq
+      rw [hcl] at hsymb
+      cases hsymb
+  | cons a args ih =>
+    simp only [List.foldr_cons]
+    intro e' hred
+    generalize hf :
+      args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) = fhead at hred ih
+    cases hred with
+    | app h1 => exact ih _ h1
+    | major h1 _ =>
+      obtain ⟨p, ⟨r', hp⟩, p₁, p₂, hsub, m1', m2', hm⟩ := h1
+      cases Params.simple_appS hp hsub
+      subst hf
+      obtain ⟨ch, lsh, argsh, heqh, harh⟩ := hm.head_spine
+      obtain ⟨rfl, -, rfl⟩ := spine_inj args argsh heqh
+      have hhead := Pattern.WF.arity_head harh (Params.pat_wf hp).1
+      rw [hcl] at hhead
+      cases hhead
+    | beta =>
+      cases args <;> simp only [List.foldr_cons, List.foldr_nil] at hf <;> cases hf
+    | extra action =>
+      subst hf
+      obtain ⟨c', ls', args', heq, hsymb⟩ :=
+        Params.matchesS_symb_head action.pat action.matched
+      have heq' : (a :: args).foldr (fun (a f : SExpr) => f.app a) (.const c ls) =
+          args'.foldr (fun (a f : SExpr) => f.app a) (.const c' ls') := by
+        simpa only [List.foldr_cons] using heq
+      obtain ⟨rfl, -, rfl⟩ := spine_inj (a :: args) args' heq'
+      rw [hcl] at hsymb
+      cases hsymb
 
 theorem WHRed.determ (H1 : Γ ⊢ e ⤳ e₁) (H2 : Γ ⊢ e ⤳ e₂) : e₁ = e₂ := by
   induction H1 generalizing e₂ with
   | app l1 ih =>
     cases H2 with
     | app r1 => cases ih r1; rfl
+    | major r1 r2 => cases r1.whnf _ l1
     | beta => cases WHNF.lam _ l1
-    | extra => sorry
+    | extra action =>
+      cases action.matched with
+      | app r3 =>
+        cases IsMajorPremise.whnf ⟨_, ⟨_, action.pat⟩, _, _, .refl, _, _, r3⟩ _ l1
+      | var => cases Params.pat_not_varS action.pat
+  | major l1 l2 ih =>
+    cases H2 with
+    | app r1 => cases l1.whnf _ r1
+    | major _ r2 => cases ih r2; rfl
+    | beta => cases l1.lam
+    | extra action =>
+      cases action.matched with
+      | var => cases Params.pat_not_varS action.pat
+      | app _ r4 => cases WHNF.subpattern action.pat (.appR .refl) nofun r4 _ l2
   | beta =>
     cases H2 with
     | app r1 => cases WHNF.lam _ r1
+    | major r1 => cases r1.lam
     | beta => rfl
-    | extra _ r2 => sorry
-  | extra _ l2 =>
+    | extra action => nomatch action.matched
+  | extra actionL =>
     cases H2 with
-    | beta => sorry
-    | app => sorry
-    | extra _ r2 => sorry
+    | beta => nomatch actionL.matched
+    | major r1 r2 =>
+      cases actionL.matched with
+      | var => cases Params.pat_not_varS actionL.pat
+      | app _ l4 => cases WHNF.subpattern actionL.pat (.appR .refl) nofun l4 _ r2
+    | app r1 =>
+      cases actionL.matched with
+      | app l3 =>
+        cases IsMajorPremise.whnf ⟨_, ⟨_, actionL.pat⟩, _, _, .refl, _, _, l3⟩ _ r1
+      | var => cases Params.pat_not_varS actionL.pat
+    | extra actionR =>
+      have ⟨_, _, _, a1, a2⟩ := Pattern.matchesS_inter.1
+        ⟨⟨_, _, actionR.matched⟩, ⟨_, _, actionL.matched⟩⟩
+      obtain ⟨rfl, -, ⟨⟩⟩ := Params.pat_uniq actionL.pat actionR.pat .refl a1
+      obtain ⟨rfl, rfl⟩ := actionL.matched.determ actionR.matched
+      rfl
 
 def WHRedS (Γ : List SExpr) : SExpr → SExpr → Prop := ReflTransGen (WHRed Γ)
 scoped notation:65 Γ " ⊢ " e1 " ⤳* " e2:36 => WHRedS Γ e1 e2
 
-theorem WHRedS.subst (W : Ctx.Subst HasType Δ σ Γ) (H : Γ ⊢ e1 ⤳* e2) :
+theorem WHRedS.subst
+    (W : Ctx.Subst (fun Γ e A => Γ ⊢ e : A) Δ σ Γ)
+    (H : Γ ⊢ e1 ⤳* e2) :
     Δ ⊢ e1.subst σ ⤳* e2.subst σ := by
   induction H with
   | rfl => exact .rfl
   | tail _ h2 ih => exact .tail ih (h2.subst W)
 
+/-- Weak-head reduction is definitional equality. OPEN, and the one
+`SExpr.lean` admission on the L4L-16 gate path. Native exact iota leaves no
+longer use it: their reductions are reflexive and their typings come from
+`CtorExact`/`PatternLeafSpine`.  The remaining uses are the two root-to-view
+anchors of a normalized constructor chain (and generic compatibility
+wrappers).  Proving those anchors is part of the merged weak-inversion/type-
+uniqueness development; it cannot be replaced by an intermediate-link
+certificate because arbitrary weak-head expansion erased that typing. See
+plans/l4l-16-completion-plan.md §16C′. -/
 theorem WHRedS.defeq (H : Γ ⊢ e1 ⤳* e2) (he : Γ ⊢ e1 : A) : Γ ⊢ e1 ≡ e2 : A := sorry
 
 theorem WHRedS.weak' (W : Ctx.Lift' ρ Γ Δ) (H : Γ ⊢ e1 ⤳* e2) :
@@ -1018,6 +4439,12 @@ theorem WHRedS.app (H : Γ ⊢ e1 ⤳* e2) : Γ ⊢ e1.app a ⤳* e2.app a := by
   | rfl => exact .rfl
   | tail _ h2 ih => exact .tail ih h2.app
 
+theorem WHRedS.major (H1 : IsMajorPremise f) (H : Γ ⊢ a ⤳* a') :
+    Γ ⊢ f.app a ⤳* f.app a' := by
+  induction H with
+  | rfl => exact .rfl
+  | tail _ h2 ih => exact .tail ih (h2.major H1)
+
 theorem WHRedS.weakU_inv (W : Ctx.Lift' ρ Γ Δ) (H : Δ ⊢ e1.lift' ρ ⤳* e2') :
     ∃ e2, e2' = e2.lift' ρ ∧ Γ ⊢ e1 ⤳* e2 := by
   induction H with
@@ -1053,10 +4480,17 @@ inductive ParRed : List SExpr → SExpr → SExpr → Prop where
   | lam : Γ ⊢ A ≫ A' → A::Γ ⊢ body ≫ body' → Γ ⊢ .lam A body ≫ .lam A' body'
   | forallE : Γ ⊢ A ≫ A' → A::Γ ⊢ B ≫ B' → Γ ⊢ .forallE A B ≫ .forallE A' B'
   | beta : A::Γ ⊢ e₁ ≫ e₁' → Γ ⊢ e₂ ≫ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ≫ e₁'.inst e₂'
-  | extra : Pat p r → p.MatchesS e m1 m2 → (dfs : List _).map (·.2) = r.2.defeqsS m1 m2 →
-    (∀ a b A, (A, a, b) ∈ dfs → Γ ⊢ a ≡ b : A) →
+  | extra : Pattern.Action Γ r e m1 m2 A →
     (∀ a, Γ ⊢ m2 a ≫ m2' a) → Γ ⊢ e ≫ r.1.applyS m1 m2'
 
+protected theorem ParRed.rfl : ∀ {e}, Γ ⊢ e ≫ e
+  | .bvar .. => .bvar
+  | .sort .. => .sort
+  | .const .. => .const
+  | .app .. => .app ParRed.rfl ParRed.rfl
+  | .lam .. => .lam ParRed.rfl ParRed.rfl
+  | .forallE .. => .forallE ParRed.rfl ParRed.rfl
+
 theorem ParRed.weak' (W : Ctx.Lift' ρ Γ Γ') :
     Γ ⊢ e1 ≫ e2 → Γ' ⊢ e1.lift' ρ ≫ e2.lift' ρ
   | .bvar => .bvar
@@ -1066,7 +4500,9 @@ theorem ParRed.weak' (W : Ctx.Lift' ρ Γ Γ') :
   | .lam h1 h2 => .lam (h1.weak' W) (h2.weak' W.cons)
   | .forallE h1 h2 => .forallE (h1.weak' W) (h2.weak' W.cons)
   | .beta h1 h2 => by rw [SExpr.lift'_inst_hi]; exact (h1.weak' W.cons).beta (h2.weak' W)
-  | .extra h1 h2 h3 h4 h5 => sorry
+  | extra action hred => by
+    rw [Pattern.RHS.lift'_applyS]
+    exact .extra (action.weak' W) fun a => (hred a).weak' W
 
 def ParRedS (Γ : List SExpr) : SExpr → SExpr → Prop := ReflTransGen (ParRed Γ)
 scoped notation:65 Γ " ⊢ " e1 " ≫* " e2:36 => ParRedS Γ e1 e2
@@ -1082,14 +4518,12 @@ inductive InferType : List SExpr → SExpr → SExpr → Prop where
   | bvar : Lookup Γ i A → Γ ⊢ .bvar i ▷ A
   | sort : Γ ⊢ .sort u ▷ .sort (.succ u)
   | const : env.constants c = some ci → ls.length = ci.uvars →
-    Γ ⊢ .const c ls ▷ (SExpr.mk ci.type).instL ls
+    Γ ⊢ .const c ls ▷ SExpr.mkInst ls ci.type
   | app : Γ ⊢ f ▷ F → Γ ⊢ F ⤳* .forallE A B → Γ ⊢ a :↑ A → Γ ⊢ .app f a ▷ B.inst a
   | lam : Γ ⊢ A :↑ .sort u → A::Γ ⊢ body ▷ B → Γ ⊢ .lam A body ▷ .forallE A B
   | forallE : Γ ⊢ A ▷ U → Γ ⊢ U ⤳* .sort u →
     A::Γ ⊢ B ▷ V → A::Γ ⊢ V ⤳* .sort v → Γ ⊢ .forallE A B ▷ .sort (.imax u v)
 
-theorem InferType.hasType (H : Γ ⊢ e ▷ A) : Γ ⊢ e : A := sorry
-
 theorem InferType.determ (H1 : Γ ⊢ e ▷ A) (H2 : Γ ⊢ e ▷ A') : A = A' := by
   induction H1 generalizing A' with
   | bvar h1 => cases H2 with | bvar h2 => exact h1.determ h2
@@ -1106,7 +4540,7 @@ theorem InferType.determ (H1 : Γ ⊢ e ▷ A) (H2 : Γ ⊢ e ▷ A') : A = A' :
 theorem InferType.weak' (W : Ctx.Lift' ρ Γ Δ) : Γ ⊢ e ▷ A → Δ ⊢ e.lift' ρ ▷ A.lift' ρ
   | .bvar h => .bvar (h.weak' W)
   | .sort => .sort
-  | .const h1 h2 => by rw [(henv.closedC h1).mkS.instL.lift'_eq .zero]; exact .const h1 h2
+  | .const h1 h2 => by rw [(henv.closedC h1).mkInstS.lift'_eq .zero]; exact .const h1 h2
   | .app h1 h2 h3 => SExpr.lift'_inst_hi .. ▸ .app (h1.weak' W) (h2.weak' W) (h3.weak' W)
   | .lam h1 h2 => .lam (h1.weak' W) (h2.weak' W.cons)
   | .forallE h1 h2 h3 h4 => .forallE (h1.weak' W) (h2.weak' W) (h3.weak' W.cons) (h4.weak' W.cons)
@@ -1119,7 +4553,7 @@ theorem InferType.weakU_inv (W : Ctx.Lift' ρ Γ Δ) (H : Δ ⊢ e.lift' ρ ▷
   | sort => let .sort _ := e; cases he; exact ⟨_, rfl, .sort⟩
   | const h1 h2 =>
     let .const .. := e; cases he
-    exact ⟨_, ((henv.closedC h1).mkS.instL.lift'_eq .zero).symm, .const h1 h2⟩
+    exact ⟨_, ((henv.closedC h1).mkInstS.lift'_eq .zero).symm, .const h1 h2⟩
   | app h1 h2 h3 ih =>
     let .app .. := e; cases he
     obtain ⟨_, rfl, a1⟩ := ih W rfl
@@ -1141,31 +4575,17 @@ theorem InferType.weak'_inv (W : Ctx.Lift' ρ Γ Δ) (H : Δ ⊢ e.lift' ρ ▷
   obtain ⟨_, h1, h2⟩ := H.weakU_inv W
   exact SExpr.lift'_inj.1 h1 ▸ h2
 
-theorem InferType.subst (W : Ctx.Subst InferType Δ σ Γ)
-    (H : Γ ⊢ e ▷ A) : Δ ⊢ e.subst σ ▷ A.subst σ := by
-  induction H generalizing Δ σ with
-  | @bvar Γ i A h =>
-    simp [SExpr.subst]
-    induction W generalizing i A with | nil | @cons Γ σ B W h' ih <;> cases h
-    case zero => rw [SExpr.lift, SExpr.subst_lift']; exact h'
-    case succ i C h => rw [SExpr.lift, SExpr.subst_lift']; exact ih h
-  | sort => exact .sort
-  | const h1 h2 =>
-    rw [(henv.closedC h1).mkS.instL.subst_eq .zero]
-    exact .const h1 h2
-  | app h1 h2 h3 ih => exact subst_inst ▸ .app (ih W) (h2.subst W) (h3.subst W)
-  | lam h1 h2 ih => exact .lam (h1.subst W) (ih (W.lift .bvar))
-  | forallE h1 h2 h3 h4 ih1 ih2 =>
-    exact .forallE (ih1 W) (h2.subst W) (ih2 (W.lift .bvar)) (h4.subst (W.lift .bvar))
-
-theorem InferType.inst (H₀ : Γ ⊢ a ▷ A₀) (H : A₀::Γ ⊢ e ▷ A) :
-    Γ ⊢ e.inst a ▷ A.inst a := .subst (.one H₀) H
+/- `InferType.subst`/`InferType.inst` were deleted together with the
+unsound `IsDefEqLift.subst`: their `app`/`lam` cases consumed it at the
+instance `HasType := InferType`, i.e. their proofs rested on exactly the
+free-relation unsoundness that forced the deletion, and their only
+consumer was the also-deleted `InferType.whRed`. Restoring them requires
+a `Ctx.Subst` premise whose entries carry `:↑` (lift-stable) typings,
+which no current development needs. -/
 
 def InferTypeS (Γ : List SExpr) (e A : SExpr) := ∃ A', Γ ⊢ e ▷ A' ∧ Γ ⊢ A' ⤳* A
 scoped notation:65 Γ " ⊢ " e1 " ▷* " e2:36 => InferTypeS Γ e1 e2
 
-theorem InferTypeS.hasType : Γ ⊢ e ▷* A → Γ ⊢ e : A := sorry
-
 theorem WHRedS.inferType
     (H1 : Γ ⊢ e ⤳* e₁) (W1 : WHNF Γ e₁)
     (H2 : Γ ⊢ e ⤳* e₂) (W2 : WHNF Γ e₂) : e₁ = e₂ := by
@@ -1179,7 +4599,45 @@ theorem WHRedS.inferType
     | rfl => cases W2 _ l1
     | head r1 r2 => cases l1.determ r1; exact ih r2 W2
 
-theorem WHRedS.parRedS (H : Γ ⊢ e ⤳* e') : Γ ⊢ e ≫* e' := sorry
+/-- A classified constructor spine only reduces to itself. -/
+theorem WHRedS.ctorSpine_eq {c : Name} {k : Nat} {ls : List SLevel}
+    (hcl : Params.classify c = some (.ctor k)) {args : List SExpr}
+    (H : Γ ⊢ args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) ⤳* e') :
+    e' = args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) := by
+  have gen : ∀ {e₀ e'}, Γ ⊢ e₀ ⤳* e' →
+      e₀ = args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) →
+      e' = args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) := by
+    intro e₀ e' H
+    induction H using ReflTransGen.headIndOn with
+    | rfl => exact id
+    | head h1 _ _ => rintro rfl; cases WHNF.ctorSpine hcl args _ h1
+  exact gen H rfl
+
+/-- Two weak-head reductions of one term to classified constructor spines
+land on the same syntactic spine.  This is the midpoint agreement used to
+concatenate constructor-observation chains. -/
+theorem WHRedS.ctorSpine_determ
+    {c c' : Name} {k k' : Nat} {ls ls' : List SLevel}
+    {args args' : List SExpr}
+    (hc : Params.classify c = some (.ctor k))
+    (hc' : Params.classify c' = some (.ctor k'))
+    (H1 : Γ ⊢ e ⤳* args.foldr (fun (a f : SExpr) => f.app a) (.const c ls))
+    (H2 : Γ ⊢ e ⤳* args'.foldr (fun (a f : SExpr) => f.app a) (.const c' ls')) :
+    args.foldr (fun (a f : SExpr) => f.app a) (.const c ls) =
+      args'.foldr (fun (a f : SExpr) => f.app a) (.const c' ls') :=
+  WHRedS.inferType H1 (.ctorSpine hc args) H2 (.ctorSpine hc' args')
+
+theorem WHRed.parRed (H : Γ ⊢ e ⤳ e') : Γ ⊢ e ≫ e' := by
+  induction H with
+  | app _ ih => exact .app ih .rfl
+  | major _ _ ih => exact .app .rfl ih
+  | beta => exact .beta .rfl .rfl
+  | extra action => exact .extra action fun _ => .rfl
+
+theorem WHRedS.parRedS (H : Γ ⊢ e ⤳* e') : Γ ⊢ e ≫* e' := by
+  induction H with
+  | rfl => exact .rfl
+  | tail _ h2 ih => exact .tail ih h2.parRed
 
 theorem InferTypeS.determ
     (H1 : Γ ⊢ e ▷* A) (W1 : WHNF Γ A)
@@ -1190,17 +4648,11 @@ theorem InferTypeS.determ
 theorem InferTypeS.weak' (W : Ctx.Lift' ρ Γ Δ) : Γ ⊢ e ▷* A → Δ ⊢ e.lift' ρ ▷* A.lift' ρ
   | ⟨_, h1, h2⟩ => ⟨_, h1.weak' W, h2.weak' W⟩
 
-theorem InferTypeS.weakU_inv (W : Ctx.Lift' ρ Γ Δ) (H : Δ ⊢ e.lift' ρ ▷* A') :
-    ∃ A, A' = A.lift' ρ ∧ Γ ⊢ e ▷* A := by
-  let ⟨_, h1, h2⟩ := H
-  obtain ⟨_, rfl, a1⟩ := h1.weakU_inv W
-  obtain ⟨_, rfl, a2⟩ := h2.weakU_inv W
-  exact ⟨_, rfl, _, a1, a2⟩
-
 scoped notation:65 Γ " ⊢ " e1 " ≡ₚ " e2 " : " A:36 => NormalEq Γ e1 e2 A
 inductive NormalEq : List SExpr → SExpr → SExpr → SExpr → Prop where
   | refl : Γ ⊢ e : A → Γ ⊢ e ≡ₚ e : A
   | appDF : Γ ⊢ f₁ ≡ₚ f₂ : .forallE A B → Γ ⊢ a₁ ≡ₚ a₂ : A →
+    Γ ⊢ B.inst a₁ ≡ B.inst a₂ : .sort v →
     Γ ⊢ .app f₁ a₁ ≡ₚ .app f₂ a₂ : B.inst a₁
   | lamDF : Γ ⊢ A₁ ≡ A : .sort u → Γ ⊢ A₂ ≡ A : .sort u → A::Γ ⊢ B : .sort v →
     A::Γ ⊢ body₁ ≡ₚ body₂ : B → Γ ⊢ .lam A₁ body₁ ≡ₚ .lam A₂ body₂ : .forallE A B
@@ -1218,7 +4670,7 @@ theorem NormalEq.defeqDFC (W : IsDefEqCtx Γ₀ Γ₁ Γ₂)
     (H : Γ₁ ⊢ e1 ≡ₚ e2 : A) : Γ₂ ⊢ e1 ≡ₚ e2 : A := by
   induction H generalizing Γ₂ with
   | refl h => refine .refl (h.defeqDFC W)
-  | appDF h1 h2 ih1 ih2 => exact .appDF (ih1 W) (ih2 W)
+  | appDF h1 h2 h3 ih1 ih2 => exact .appDF (ih1 W) (ih2 W) (h3.defeqDFC W)
   | lamDF h1 h2 h3 _ ih2 =>
     exact .lamDF (h1.defeqDFC W) (h2.defeqDFC W)
       (h3.defeqDFC (W.succ h1.hasType.2)) (ih2 (W.succ h1.hasType.2))
@@ -1234,7 +4686,7 @@ theorem NormalEq.defeqDFC (W : IsDefEqCtx Γ₀ Γ₁ Γ₂)
 theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2 : A) : Γ ⊢ e1 ≡ e2 : A := by
   induction H with
   | refl h => exact h
-  | appDF h1 h2 ih1 ih2 => exact .appDF ih1 ih2
+  | appDF h1 h2 _ ih1 ih2 => exact .appDF ih1 ih2
   | lamDF hA₁ hA₂ hB _ ihB =>
     exact have W := .succ .zero hA₁.symm
       .defeqDF (.forallEDF hA₁ (hB.defeqDFC W)) (.lamDF (hA₁.trans hA₂.symm) (ihB.defeqDFC W))
@@ -1248,7 +4700,7 @@ theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2 : A) : Γ ⊢ e1 ≡ e2 : A := b
 theorem NormalEq.symm (H : Γ ⊢ e1 ≡ₚ e2 : A) : Γ ⊢ e2 ≡ₚ e1 : A := by
   induction H with
   | refl h => exact .refl h
-  | appDF h1 h2 ih1 ih2 => exact .defeqDF sorry (u := sorry) <| .appDF ih1 ih2
+  | appDF h1 h2 h3 ih1 ih2 => exact .defeqDF h3.symm <| .appDF ih1 ih2 h3.symm
   | lamDF h1 h2 h3 _ ih2 => exact .lamDF h2 h1 h3 ih2
   | forallEDF h1 h2 _ _ ih1 ih2 => exact .forallEDF h2 h1 ih1 ih2
   | etaL h1 h2 h3 _ ih => exact .etaR h1 h2 h3 ih
@@ -1260,7 +4712,10 @@ theorem NormalEq.weak' (W : Ctx.Lift' ρ Γ Γ') (H : Γ ⊢ e1 ≡ₚ e2 : A) :
     Γ' ⊢ e1.lift' ρ ≡ₚ e2.lift' ρ : A.lift' ρ := by
   induction H generalizing Γ' ρ with
   | refl h => exact .refl (h.weak' W)
-  | appDF h1 h2 ih1 ih2 => exact .defeqDF sorry (u := sorry) <| .appDF (ih1 W) (ih2 W)
+  | appDF h1 h2 h3 ih1 ih2 =>
+    simpa only [SExpr.lift', SExpr.lift'_inst_hi] using
+      (NormalEq.appDF (ih1 W) (ih2 W) (by
+        simpa only [SExpr.lift'_inst_hi, SExpr.lift'] using h3.weak' W))
   | lamDF h1 h2 h3 _ ih2 => exact .lamDF (h1.weak' W) (h2.weak' W) (h3.weak' W.cons) (ih2 W.cons)
   | forallEDF h1 h2 _ _ ih1 ih2 => exact .forallEDF (h1.weak' W) (h2.weak' W) (ih1 W) (ih2 W.cons)
   | etaL h1 h2 h3 _ ih =>
@@ -1291,8 +4746,13 @@ theorem CRDefEq.defeq : Γ ⊢ e₁ ≫≪ e₂ : A → Γ ⊢ e₁ ≡ e₂ : A
 theorem CRDefEq.symm : Γ ⊢ e₁ ≫≪ e₂ : A → Γ ⊢ e₂ ≫≪ e₁ : A
   | ⟨h1, _, _, h3, h4, h5⟩ => ⟨h1.symm, _, _, h4, h3, h5.symm⟩
 
-theorem CRDefEq.trans : Γ ⊢ e₁ ≫≪ e₂ : A → Γ ⊢ e₂ ≫≪ e₃ : A → Γ ⊢ e₁ ≫≪ e₃ : A
-  | ⟨l1, _, _, l3, l4, l5⟩, ⟨r1, _, _, r3, r4, r5⟩ => sorry
+/- There is deliberately no `CRDefEq.trans` here. Its Theory counterpart
+is five lines from `ParRedS.church_rosser`, `NormalEq.parRedS`, and
+`NormalEq.trans`; none of that development exists on the SExpr side, and
+Theory's own `NormalEq.parRed` `.extra` overlap cases are the open
+L4L-18A obligations. Porting the joining argument lands with L4L-18A
+against the finished Theory script — see plans/l4l-16-completion-plan.md
+§L4L-18A′ — and nothing on the L4L-16 gate path consumes it. -/
 
 theorem CRDefEq.defeqDF : Γ ⊢ e₁ ≫≪ e₂ : A → Γ ⊢ A ≡ B : .sort u → Γ ⊢ e₁ ≫≪ e₂ : B
   | ⟨l1, _, _, l3, l4, l5⟩, H => ⟨H.defeqDF l1, _, _, l3, l4, l5.defeqDF H⟩
@@ -1313,12 +4773,12 @@ theorem CRDefEqLift.left (H : Γ ⊢ e1 ≫≪ e2 :↑ A) : Γ ⊢ e1 :↑ A :=
 nonrec theorem CRDefEqLift.refl (H : Γ ⊢ e :↑ A) : Γ ⊢ e ≫≪ e :↑ A :=
   .refl (.refl <| H.left' · · ·)
 
-theorem InferType.whRed (H1 : Γ ⊢ e ⤳ e') (H2 : Γ ⊢ e ▷ A) : Γ ⊢ e' ▷ A := by
-  induction H1 generalizing A with
-  | app h1 ih => let .app r1 r2 r3 := H2; exact .app (ih r1) r2 r3
-  | beta =>
-    let .app a1 a2 a3 := H2
-    let .lam b1 b2 := a1
-    cases WHNF.forallE.whRedS a2
-    exact .inst sorry b2
-  | extra => sorry
+/- There is deliberately no `InferType.whRed` (subject reduction for
+inferred types under one weak-head step). The former statement was false
+as written: `▷` is syntax-directed with no conversion rule, so a `major`
+step changes the inferred type from `B.inst a` to the merely-defeq
+`B.inst a'`, a `beta` redex's argument is typed (`:↑`) at a domain that
+need not be its principal type, and a `Pattern.Action` supplies a typing
+of the RHS, not an inference. If a successor milestone needs this fact,
+state it up to conversion (`Γ ⊢ e' ▷* A'` with `Γ ⊢ A ≡ A' : .sort u`);
+Theory has no counterpart to port. -/
diff --git a/Lean4Lean/Experimental/SExprGenericReplay.lean b/Lean4Lean/Experimental/SExprGenericReplay.lean
new file mode 100644
index 00000000..52c052ed
--- /dev/null
+++ b/Lean4Lean/Experimental/SExprGenericReplay.lean
@@ -0,0 +1,429 @@
+import Lean4Lean.Experimental.SExpr
+import Lean4Lean.Theory.Typing.InductivePatternWF
+
+/-!
+# L4L-16 R2: the generic per-rule replay engine
+
+D0 and D1 each replay their generated iota rules *by hand*, once per rule:
+roughly 640 lines for `SExprParamsD0.lean`'s two `Nat` rules and 340 for
+`SExprParamsD1.lean`'s re-basing of them.  Almost none of that volume is
+rule-specific.  This module extracts the rule-independent part as a single
+engine, parameterized only by
+
+* an ambient `[Params]` with `env.WF` and a `Params.StructureEtaSound`
+  certificate (the two facts a fixture instance establishes once), and
+* the *structural* shape of one registered rule — `df.lhs = lamN binders
+  body`, `df.type = forallN binders result` — which for a certified block is
+  `BlockGenerationChecked.rule_lhs`/`rule_type`, i.e. `rfl`.
+
+What is left for a rule's own glue is exactly the two things that genuinely
+vary: naming its recursor/constructor and levels, and supplying the
+per-argument typings that build the canonical spine.
+
+Contents:
+
+* §1 the ambient certificate `Replay` and the type-uniqueness tower
+  (`typeUniq`, `typesTrans`, `typesInst`, `forallEInv`), generic versions of
+  `d1TypeUniq` … `d1ForallEInv`;
+* §2 the spine views (`SpineConsView`, `pathSpineOfSpineWF`), generic
+  versions of `d1SpineConsView` and `d1PathSpineOfSpineWF`;
+* §3 the β-collapse engine `ruleCollapse` — the reify → `instL_lamN` →
+  `lamN_wf` → `SpineWF.retarget` → `appN_lamN` → `IsDefEq.mkS` chain that
+  every rule replay runs verbatim;
+* §4 the site assembler `iotaSiteOf`, which turns the collapse plus a
+  rule's own capture data into a `Pattern.IotaReductionSite`, taking the
+  `Pattern.Check` discharge as an explicit hypothesis (see the D2 record:
+  that discharge is `L4L-18A′`-gated at a general matched redex).
+-/
+
+namespace Lean4Lean
+namespace SExpr
+
+/-! ## §1 The ambient replay certificate -/
+
+/-- The two ambient facts a fixture instance supplies once, after which
+every per-rule replay is generic.  `wf` powers type uniqueness through
+Theory's inversion lemmas; `structEta` powers the `IsDefEq.mkS` transfer
+back from Theory into the quotiented syntax. -/
+structure Replay [Params] : Prop where
+  wf : Params.env.WF
+  structEta : Params.StructureEtaSound
+
+variable [Params] (R : Replay)
+
+/-- Reified validity of a working context. -/
+def CtxValid (Γ : List SExpr) : Prop :=
+  OnCtx (Γ.map SExpr.reify) (Params.env.IsType Params.univs)
+
+/-- Two types of one term are definitionally equal at some sort. -/
+def TypesDefEq (Γ : List SExpr) (A B : SExpr) : Prop :=
+  ∃ u, IsDefEq Γ A B (.sort u)
+
+theorem ctx_mk_reify (Γ : List SExpr) :
+    (Γ.map SExpr.reify).map SExpr.mk = Γ := by
+  rw [List.map_map]
+  exact List.map_id''' Γ fun term _ => SExpr.mk_reify term
+
+include R in
+theorem typeUniq {Γ : List SExpr} {x A B : SExpr}
+    (hΓ : CtxValid Γ) (hxA : IsDefEq Γ x x A) (hxB : IsDefEq Γ x x B) :
+    TypesDefEq Γ A B := by
+  have hxA' := hxA.reify hΓ
+  have hxB' := hxB.reify hΓ
+  obtain ⟨u, hAB⟩ := hxA'.uniq R.wf hΓ hxB'
+  have hlevels := (VEnv.CtxStrong.strong Params.henv hΓ).levelWF
+  have hAB' := SExpr.IsDefEq.mkS R.structEta hAB hlevels
+  rw [ctx_mk_reify] at hAB'
+  exact ⟨SLevel.mk u, by simpa only [SExpr.mk_reify, SExpr.mk] using hAB'⟩
+
+include R in
+theorem typesTrans {Γ : List SExpr} {A B C : SExpr}
+    (hΓ : CtxValid Γ) (hAB : TypesDefEq Γ A B) (hBC : TypesDefEq Γ B C) :
+    TypesDefEq Γ A C := by
+  obtain ⟨u, hAB⟩ := hAB
+  obtain ⟨v, hBC⟩ := hBC
+  obtain ⟨w, huv⟩ := typeUniq R hΓ hAB.hasType.2 hBC.hasType.1
+  exact ⟨u, hAB.trans (huv.symm.defeqDF hBC)⟩
+
+theorem typesInst {Γ : List SExpr} {D B B' e : SExpr}
+    (hBB' : TypesDefEq (D :: Γ) B B') (he : IsDefEq Γ e e D) :
+    TypesDefEq Γ (B.inst e) (B'.inst e) := by
+  obtain ⟨u, hBB'⟩ := hBB'
+  exact ⟨u, hBB'.subst (Ctx.Subst.one IsDefEq.weak' IsDefEq.bvar he)⟩
+
+include R in
+theorem forallEInv {Γ : List SExpr} {A B A' B' : SExpr}
+    (hΓ : CtxValid Γ)
+    (hPi : TypesDefEq Γ (.forallE A B) (.forallE A' B')) :
+    TypesDefEq Γ A A' ∧ TypesDefEq (A :: Γ) B B' := by
+  obtain ⟨_, hPi⟩ := hPi
+  have hPi' := hPi.reify hΓ
+  have hPiU : Params.env.IsDefEqU Params.univs (Γ.map SExpr.reify)
+      (.forallE A.reify B.reify) (.forallE A'.reify B'.reify) := ⟨_, hPi'⟩
+  obtain ⟨⟨u, hA⟩, v, hB⟩ := hPiU.forallE_inv R.wf hΓ
+  have hlevels := (VEnv.CtxStrong.strong Params.henv hΓ).levelWF
+  have hA' := SExpr.IsDefEq.mkS R.structEta hA hlevels
+  rw [ctx_mk_reify] at hA'
+  have hAwf : (A.reify).LevelWF Params.univs := SExpr.reify_levelWF A
+  have hB' := SExpr.IsDefEq.mkS R.structEta hB ⟨hlevels, hAwf⟩
+  have hBctx : ((A.reify :: Γ.map SExpr.reify).map SExpr.mk) = A :: Γ := by
+    rw [List.map_cons, ctx_mk_reify, SExpr.mk_reify]
+  rw [hBctx] at hB'
+  exact ⟨⟨SLevel.mk u, by simpa only [SExpr.mk_reify, SExpr.mk] using hA'⟩,
+    ⟨SLevel.mk v, by simpa only [SExpr.mk_reify, SExpr.mk] using hB'⟩⟩
+
+/-! ## §2 Spine views -/
+
+/-- One peeled application of a conversion-aware spine: the exact domain and
+codomain the spine used, with the argument's typing and the tail. -/
+structure SpineConsView (Γ : List SExpr) (D B e : SExpr) (es : List SExpr)
+    (Res : SExpr) where
+  domain : SExpr
+  codomain : SExpr
+  domainEq : TypesDefEq Γ D domain
+  codomainEq : TypesDefEq (D :: Γ) B codomain
+  argument : IsDefEq Γ e e domain
+  tail : SpineWF Γ (codomain.inst e) es Res
+
+include R in
+theorem spineConsView_nonempty {Γ : List SExpr} {D B Head e Res : SExpr}
+    {es : List SExpr}
+    (hΓ : CtxValid Γ) (hHead : TypesDefEq Γ (.forallE D B) Head)
+    (H : SpineWF Γ Head (e :: es) Res) :
+    Nonempty (SpineConsView Γ D B e es Res) := by
+  generalize hargsEq : e :: es = args at H
+  induction H generalizing D B e es with
+  | nil => cases hargsEq
+  | @cons _ domain _ _ codomain harg htail ih =>
+    cases hargsEq
+    obtain ⟨hdom, hbody⟩ := forallEInv R hΓ hHead
+    exact ⟨{ domain := domain, codomain := codomain, domainEq := hdom
+             codomainEq := hbody, argument := harg, tail := htail }⟩
+  | @conv _ Head' u _ _ hconv htail ih =>
+    exact ih (typesTrans R hΓ hHead ⟨u, hconv⟩) hargsEq
+  | @ret _ _ R' _ _ htail hret ih =>
+    let ⟨view⟩ := ih hHead hargsEq
+    exact ⟨{ view with tail := .ret view.tail hret }⟩
+
+noncomputable def spineConsView {Γ : List SExpr} {D B Head e Res : SExpr}
+    {es : List SExpr}
+    (hΓ : CtxValid Γ) (hHead : TypesDefEq Γ (.forallE D B) Head)
+    (H : SpineWF Γ Head (e :: es) Res) : SpineConsView Γ D B e es Res :=
+  Classical.choice (spineConsView_nonempty R hΓ hHead H)
+
+theorem SpineConsView.argumentExpected {Γ : List SExpr} {D B e Res : SExpr}
+    {es : List SExpr} (view : SpineConsView Γ D B e es Res) :
+    IsDefEq Γ e e D := by
+  obtain ⟨_, hdom⟩ := view.domainEq
+  exact hdom.symm.defeqDF view.argument
+
+theorem SpineConsView.restEq {Γ : List SExpr} {D B e Res : SExpr}
+    {es : List SExpr} (view : SpineConsView Γ D B e es Res) :
+    TypesDefEq Γ (B.inst e) (view.codomain.inst e) :=
+  typesInst view.codomainEq view.argumentExpected
+
+include R in
+/-- Re-index a spine by the paths that selected its arguments. -/
+theorem pathSpineOfSpineWF {Γ : List SExpr} {alpha : Type}
+    {value type : alpha → SExpr} {A B : SExpr} {paths : List alpha}
+    (hΓ : CtxValid Γ)
+    (htyped : ∀ path, IsDefEq Γ (value path) (value path) (type path))
+    (H : SpineWF Γ A (paths.map value) B) :
+    PathSpineWF Γ value type A paths B := by
+  generalize hargs : paths.map value = args at H
+  induction H generalizing paths with
+  | nil =>
+    have hpaths : paths = [] := by simpa using hargs
+    subst paths
+    exact .nil
+  | @cons e domain es result codomain harg htail ih =>
+    cases paths with
+    | nil => simp at hargs
+    | cons path paths =>
+      simp only [List.map_cons, List.cons.injEq] at hargs
+      obtain ⟨hvalue, hrest⟩ := hargs
+      subst e
+      obtain ⟨_, hdomain⟩ := typeUniq R hΓ (htyped path) harg
+      exact .cons hdomain (ih hrest)
+  | @conv Head Head' u es result hHead htail ih => exact .conv hHead (ih hargs)
+  | @ret Head es result result' u htail hresult ih => exact .ret (ih hargs) hresult
+
+/-! ## §3 The β-collapse engine
+
+`ruleCollapse` is the rule-independent heart of every generated-iota
+replay.  D0 and D1 inline it once per rule; here it is proved once. -/
+
+/-- Semantic translation of an iterated application. -/
+theorem mk_appN : ∀ (as : List VExpr) (f : VExpr),
+    SExpr.mk (VExpr.appN f as) =
+      (as.map SExpr.mk).foldl (fun (g a : SExpr) => g.app a) (SExpr.mk f)
+  | [], _ => rfl
+  | a :: as, f => by
+    show SExpr.mk (VExpr.appN (f.app a) as) = _
+    rw [mk_appN as (f.app a)]
+    rfl
+
+@[simp] theorem map_mk_map_reify (as : List SExpr) :
+    (as.map SExpr.reify).map SExpr.mk = as := by
+  rw [List.map_map]
+  exact List.map_id''' as fun e _ => SExpr.mk_reify e
+
+include R in
+/-- **The generic replay lemma.**  A registered rule whose left tower is a
+lambda telescope over `body`, applied to a full well-typed argument spine,
+β-collapses to the iterated instantiation of `body` — with no reference
+whatever to which rule, which block, or which constructor is involved.
+
+The spine premise is stated on the Theory side because Theory's `SpineWF`
+has no conversion constructor; a rule's own glue builds it with `.cons`
+from the per-argument typings it has just extracted, which is exactly the
+form in which those typings arrive. -/
+theorem ruleCollapse {Γ : List SExpr} {df : VDefEq}
+    {binders : List VExpr} {body result : VExpr}
+    {ls : List SLevel} {args : List SExpr}
+    (hΓ : CtxValid Γ)
+    (hreg : Params.env.defeqs df)
+    (hlhs : df.lhs = VExpr.lamN binders body)
+    (_htype : df.type = VExpr.forallN binders result)
+    (_hls : ls.length = df.uvars)
+    (hlen : args.length = binders.length)
+    (hspine : Params.env.SpineWF Params.univs (Γ.map SExpr.reify)
+      (VExpr.forallN (binders.map (VExpr.instL (ls.map SLevel.reify)))
+        (result.instL (ls.map SLevel.reify)))
+      (args.map SExpr.reify)
+      (VExpr.instRev (result.instL (ls.map SLevel.reify))
+        (args.map SExpr.reify))) :
+    ∃ B, IsDefEq Γ
+      (args.foldl (fun (f a : SExpr) => f.app a) (SExpr.mkInst ls df.lhs))
+      (SExpr.mk ((body.instL (ls.map SLevel.reify)).instRev
+        (args.map SExpr.reify))) B := by
+  have hvls : ∀ l ∈ ls.map SLevel.reify, l.WF Params.univs := by
+    intro l hl
+    simp only [List.mem_map] at hl
+    obtain ⟨sl, -, rfl⟩ := hl
+    exact SLevel.reify_wf sl
+  have hlenV : (args.map SExpr.reify).length =
+      (binders.map (VExpr.instL (ls.map SLevel.reify))).length := by
+    simp only [List.length_map]
+    exact hlen
+  -- the rule's left tower, typed at the working context
+  have hlhsClosed :=
+    (Params.henv.defEqWF hreg).1.instL (ls := ls.map SLevel.reify) hvls
+  have hlhsGamma : Params.env.HasType Params.univs (Γ.map SExpr.reify)
+      (df.lhs.instL (ls.map SLevel.reify))
+      (df.type.instL (ls.map SLevel.reify)) :=
+    hlhsClosed.weak0 Params.henv
+  rw [hlhs, VExpr.instL_lamN] at hlhsGamma
+  obtain ⟨hTel, bodyType, hbody⟩ :=
+    VEnv.HasType.lamN_wf Params.henv hΓ hlhsGamma
+  -- retarget the canonical spine at the recovered body type
+  have hspineBody := VEnv.SpineWF.retarget hspine hlenV bodyType
+  have hcollapseV :=
+    VEnv.IsDefEq.appN_lamN Params.henv hTel hbody hspineBody hlenV
+  -- transfer back into the quotiented syntax
+  have hlevels := (VEnv.CtxStrong.strong Params.henv hΓ).levelWF
+  have hcollapseS := SExpr.IsDefEq.mkS R.structEta hcollapseV hlevels
+  rw [ctx_mk_reify] at hcollapseS
+  rw [mk_appN, map_mk_map_reify] at hcollapseS
+  have hhead : SExpr.mk (VExpr.lamN
+        (binders.map (VExpr.instL (ls.map SLevel.reify)))
+        (body.instL (ls.map SLevel.reify))) = SExpr.mkInst ls df.lhs := by
+    rw [← VExpr.instL_lamN, ← hlhs]
+    exact SExpr.mk_instL_map_reify df.lhs ls
+  rw [hhead] at hcollapseS
+  exact ⟨_, hcollapseS⟩
+
+/-! ## §4 The site assembler
+
+Given the collapse and a rule's own capture data, the reduction site is
+assembled generically.  The `Pattern.Check` obligations are an explicit
+hypothesis: at a *general* matched redex the parameter checks are not
+derivable from the site's typing inputs (they need injectivity of a stuck
+inductive-type application, `L4L-18A′` strength), so an instance either
+proves them for its block or parks them, and this engine stays neutral. -/
+
+include R in
+/-- **The generic site assembler.**  Every field of `IotaReductionSite`
+except `typing`/`matched` (inputs) and `checked` (the parked obligation) is
+produced here from the collapse and the capture inventory. -/
+noncomputable def iotaSiteOf
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Γ : List SExpr} {A majorTerm : SExpr} {recLs ctorLs : List SLevel}
+    {recArgs ctorArgs : List SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    (rule : Pattern.IotaRule r)
+    (captureTyping : Pattern.CaptureTyping Γ mcap captureType)
+    (hΓ : CtxValid Γ)
+    (typing : Pattern.IotaTyping Γ rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : (RecursorIotaPattern rec major ctor arity).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs))) recLs mcap)
+    (levelsLength : recLs.length = rule.df.uvars)
+    /- the rule's own capture spine, at the instantiated rule type -/
+    (hspine : SpineWF Γ (SExpr.mkInst recLs rule.df.type)
+      (rule.capturePaths.map mcap) A)
+    /- the β-collapse of the applied left tower back to the matched redex -/
+    (lhsCollapse : IsDefEq Γ
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs)))
+      ((rule.capturePaths.map mcap).foldl
+        (fun (f a : SExpr) => f.app a) (SExpr.mkInst recLs rule.df.lhs)) A)
+    /- the parked `Pattern.Check` discharge -/
+    (dfs : List (SExpr × SExpr × SExpr))
+    (hdefeqs : dfs.map (·.2) = r.2.defeqsS recLs mcap)
+    (hchecked : ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Γ a b B) :
+    Pattern.IotaReductionSite Γ r rule recLs ctorLs recArgs ctorArgs
+      majorTerm A mcap captureType captureTyping where
+  typing := typing
+  matched := matched
+  levelsLength := levelsLength
+  captureSpine := pathSpineOfSpineWF R hΓ captureTyping.typed hspine
+  lhsCollapse := lhsCollapse
+  dfs := dfs
+  defeqs := hdefeqs
+  checked := hchecked
+
+
+/-! ## §5 Level extraction and the reified-spine bridge (R3)
+
+Two further generic pieces consumed by block instances whose constructors
+carry universe parameters (the first being D2's `Tree`/`TreeList`).
+
+* `sortInj` — the quotiented-level form of sort injectivity: two
+  definitionally equal sorts have *equal* `SLevel`s.  It rides on
+  `VEnv.IsDefEqU.sort_inv`, one of the sorried 16C′-cluster leaves in
+  `Theory/Typing/Injectivity.lean` that `typeUniq` (via
+  `VEnv.IsDefEq.uniq`) already consumes, so it adds no admission beyond the
+  engine's existing closure.
+* `spineOfVSpineReify` — the working-context instance of
+  `VEnv.SpineWF.mkS`: a Theory-side spine at the reified context transfers
+  to a quotiented-syntax spine at the working context itself.  A rule's
+  glue builds the Theory-side spine once (the form `ruleCollapse` consumes)
+  and obtains its `iotaSiteOf` capture spine from this bridge instead of
+  rebuilding it by hand. -/
+
+/-- `SLevel.succ` is injective: the quotient is by pointwise evaluation and
+successor is pointwise `+1`. -/
+theorem _root_.Lean4Lean.SLevel.succ_inj {u v : SLevel}
+    (h : SLevel.succ u = SLevel.succ v) : u = v := by
+  apply Subtype.ext
+  funext ns
+  have h' := congrArg (·.1 ns) h
+  change u.1 ns + 1 = v.1 ns + 1 at h'
+  omega
+
+include R in
+/-- Sort injectivity at the quotiented level: definitionally equal sorts
+have equal `SLevel`s.  Inherits the 16C′ `sort_inv` leaf already inside the
+engine's closure. -/
+theorem sortInj {Γ : List SExpr} {u v : SLevel}
+    (hΓ : CtxValid Γ) (h : TypesDefEq Γ (.sort u) (.sort v)) : u = v := by
+  obtain ⟨w, h⟩ := h
+  have hV := h.reify hΓ
+  have hU : Params.env.IsDefEqU Params.univs (Γ.map SExpr.reify)
+      (.sort u.reify) (.sort v.reify) := ⟨_, hV⟩
+  have hequiv := hU.sort_inv R.wf hΓ
+  calc u = SLevel.mk u.reify := (SLevel.mk_reify u).symm
+    _ = SLevel.mk v.reify :=
+        SLevel.mk_eq (SLevel.reify_wf u) (SLevel.reify_wf v) hequiv
+    _ = v := SLevel.mk_reify v
+
+/-- Transfer a Theory-side spine over the reified working context back into
+the quotiented syntax at the working context itself. -/
+theorem spineOfVSpineReify (hstruct : Params.StructureEtaSound)
+    {Γ : List SExpr} {T Res : VExpr} {args : List SExpr}
+    (hΓ : CtxValid Γ)
+    (H : Params.env.SpineWF Params.univs (Γ.map SExpr.reify) T
+      (args.map SExpr.reify) Res) :
+    SpineWF Γ (SExpr.mk T) args (SExpr.mk Res) := by
+  have hlevels : OnCtx (Γ.map SExpr.reify)
+      (fun _ A => A.LevelWF Params.univs) :=
+    (VEnv.CtxStrong.strong Params.henv hΓ).levelWF
+  have hS := VEnv.SpineWF.mkS hstruct H hlevels
+  rw [ctx_mk_reify, map_mk_map_reify] at hS
+  exact hS
+
+/-! ## Axiom closures
+
+`ruleCollapse` — the entire reify/`instL_lamN`/`lamN_wf`/`retarget`/
+`appN_lamN`/`mkS` chain that D0 and D1 inline once per rule — is
+`sorryAx`-free: the generic engine adds no admission of its own.
+
+`typeUniq` (and everything downstream of it, including `iotaSiteOf`)
+inherits the ladder's existing `sorryAx` through `VEnv.IsDefEq.uniq`, the
+16C′ leaf that `SExprParamsD1.lean`'s `d1SortInvS` already carries.  Nothing
+here consumes `VInductDecl.BlockGenerationChecked.pat_wf`, whose own
+`sorryAx` would close a circle back through the sorried `sort_inv`. -/
+
+/-- info: 'Lean4Lean.SExpr.ruleCollapse' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms ruleCollapse
+
+/-- info: 'Lean4Lean.SExpr.mk_appN' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms mk_appN
+
+/-- info: 'Lean4Lean.SExpr.typeUniq' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms typeUniq
+
+/-- info: 'Lean4Lean.SExpr.iotaSiteOf' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms iotaSiteOf
+
+/-- info: 'Lean4Lean.SExpr.sortInj' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms sortInj
+
+/-- info: 'Lean4Lean.SExpr.spineOfVSpineReify' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms spineOfVSpineReify
+
+end SExpr
+end Lean4Lean
diff --git a/Lean4Lean/Experimental/SExprParamsD0.lean b/Lean4Lean/Experimental/SExprParamsD0.lean
new file mode 100644
index 00000000..566ae8da
--- /dev/null
+++ b/Lean4Lean/Experimental/SExprParamsD0.lean
@@ -0,0 +1,7023 @@
+import Lean4Lean.Experimental.ShapeLogRelAdequacy
+import Lean4Lean.Theory.Typing.InductivePatternEnv
+import Lean4Lean.Verify.Environment.InductiveFixtures
+
+/-!
+# L4L-16D0: a concrete `SExpr.Params` fixture
+
+This module instantiates the experimental semantic interface with the
+generated `Nat` block.  It is intentionally kept separate from the generic
+adequacy development: the fixture is an executable integration test for the
+pattern and environment certificates, not another assumption of the generic
+theory.
+-/
+
+namespace Lean4Lean
+namespace SExpr
+namespace ParamsD0
+
+open InductiveFixtures InductiveReplayFixtures VInductDecl
+
+abbrev NatGeneration := InductiveFixtures.natBlockGenerationChecked
+
+/-- The two generated Nat iota RHS towers and their (empty) check payloads
+are closed. -/
+def natRuleClosure : NatGeneration.RuleClosure :=
+  VInductDecl.BlockGenerationChecked.RuleClosure.of_all _
+    (by decide) (by decide)
+
+/-- The concrete reduction-pattern inventory for the Nat block. -/
+abbrev NatPat := NatGeneration.IotaPat natRuleClosure
+
+/-! ## D0b declaration layer
+
+The iota-only `natParams` fixture below is intentionally retained as the
+small D0a regression.  D0b extends its Theory environment with one ordinary
+definition whose value is a constructor constant; the semantic instance is
+layered over D0a later in this file. -/
+
+/-- The host declaration supplies a stable kernel name for the object-level
+definition fixture.  Its Theory payload is spelled out explicitly below. -/
+def d0def : Nat := Nat.zero
+
+/-- Object-level metadata for `d0def : Nat := Nat.zero`. -/
+def d0DefVal : VDefVal where
+  name := ``d0def
+  uvars := 0
+  type := InductiveFixtures.natType.ctors[0].type
+  value := .const ``Nat.zero []
+
+theorem d0DefVal_wf : d0DefVal.WF natFinalEnv := by
+  have hzero :
+      natFinalEnv.constants ``Nat.zero =
+        some InductiveFixtures.natType.ctors[0].toVConstant := by
+    rfl
+  exact VEnv.HasType.const (Γ := []) (ls := []) hzero (by simp) rfl
+
+theorem d0Def_fresh : natFinalEnv.constants d0DefVal.name = none := by
+  native_decide
+
+theorem d0Def_name_ne_nat : d0DefVal.name ≠ ``Nat := by native_decide
+theorem d0Def_name_ne_natZero : d0DefVal.name ≠ ``Nat.zero := by native_decide
+theorem d0Def_name_ne_natSucc : d0DefVal.name ≠ ``Nat.succ := by native_decide
+theorem d0Def_name_ne_natRec : d0DefVal.name ≠ ``Nat.rec := by native_decide
+
+local instance : Inhabited VEnv := ⟨VEnv.empty⟩
+
+def d0ConstEnv :=
+  (natFinalEnv.addConst d0DefVal.name d0DefVal.toVConstant).get!
+
+/-- The complete D0 environment: generated Nat constants/rules followed by
+one checked ordinary definition. -/
+def d0Env := d0ConstEnv.addDefEq d0DefVal.toDefEq
+
+theorem natFinalEnv_add_d0Def :
+    natFinalEnv.addConst d0DefVal.name d0DefVal.toVConstant =
+      some d0ConstEnv := by
+  simp [VEnv.addConst, d0Def_fresh, d0ConstEnv]
+
+theorem natFinalEnv_le_d0Env : natFinalEnv ≤ d0Env :=
+  (VEnv.addConst_le natFinalEnv_add_d0Def).trans VEnv.addDefEq_le
+
+theorem d0Env_wf : d0Env.WF := by
+  obtain ⟨ds, hds⟩ := InductiveReplayFixtures.nat_env_wf
+  exact ⟨.def d0DefVal :: ds,
+    .decl (.def d0DefVal_wf natFinalEnv_add_d0Def) hds⟩
+
+theorem d0Env_ordered : d0Env.Ordered := d0Env_wf.ordered
+
+theorem d0Env_d0Def_lookup :
+    d0Env.constants d0DefVal.name = some d0DefVal.toVConstant :=
+  VEnv.addDefEq_le.constants
+    (VEnv.addConst_self natFinalEnv_add_d0Def)
+
+theorem d0Env_constants_old {c : Name} {ci : VConstant}
+    (hne : c ≠ d0DefVal.name)
+    (H : d0Env.constants c = some ci) :
+    natFinalEnv.constants c = some ci := by
+  simpa [d0Env, d0ConstEnv, VEnv.addConst, d0Def_fresh,
+    VEnv.addDefEq, Ne.symm hne] using H
+
+theorem d0Env_defeqs_iff (df : VDefEq) :
+    d0Env.defeqs df ↔
+      df = d0DefVal.toDefEq ∨ natFinalEnv.defeqs df := by
+  simp [d0Env, d0ConstEnv, VEnv.addConst, d0Def_fresh,
+    VEnv.addDefEq]
+
+theorem d0Env_no_structEta (rule : VStructEta) :
+    ¬d0Env.structEtas rule := by
+  change ¬False
+  intro h
+  exact h
+
+/-- The exact head classification used by the generated Nat rules. -/
+def natClassify (n : Name) : Option Classification :=
+  if n = ``Nat then some (.indTy 0)
+  else if n = ``Nat.zero then some (.ctor 0)
+  else if n = ``Nat.succ then some (.ctor 1)
+  else if n = ``Nat.rec then some (.symb 4)
+  else none
+
+/-- D0b adds exactly one zero-arity definition head to the D0a table. -/
+def d0Classify (n : Name) : Option Classification :=
+  if n = d0DefVal.name then some (.symb 0) else natClassify n
+
+theorem d0DefClosed : d0DefVal.value.Closed := by
+  decide
+
+/-- The complete D0 pattern inventory: both generated Nat iota rules and
+the single ordinary definition rule. -/
+inductive D0Pat : (p : Pattern) → p.RHS × p.Check → Prop where
+  | iota {p : Pattern} {r : p.RHS × p.Check} : NatPat p r → D0Pat p r
+  | defn : D0Pat (.const d0DefVal.name)
+      (.fixed d0DefVal.value d0DefClosed, .true)
+
+/-- A proof-independent view of the constructor-shaped classifications.
+Unlike the `matches` syntax, this predicate does not retain the proof of the
+preceding classifier equality in its elaborated motive. -/
+def ctorLike : Classification → Bool
+  | .ctor _ | .etaCtor _ _ => true
+  | .symb _ | .indTy _ => false
+
+theorem natClassify_ctor_cases {c : Name} {cl : Classification}
+    (hc : natClassify c = some cl)
+    (hshape : ctorLike cl = true) :
+    (c = ``Nat.zero ∧ cl = .ctor 0) ∨
+      (c = ``Nat.succ ∧ cl = .ctor 1) := by
+  by_cases hNat : c = ``Nat
+  · subst c
+    simp [natClassify] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  by_cases hzero : c = ``Nat.zero
+  · subst c
+    simp [natClassify] at hc
+    exact .inl ⟨rfl, hc.symm⟩
+  by_cases hsucc : c = ``Nat.succ
+  · subst c
+    simp [natClassify] at hc
+    exact .inr ⟨rfl, hc.symm⟩
+  by_cases hrec : c = ``Nat.rec
+  · subst c
+    simp [natClassify] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  · simp [natClassify, hNat, hzero, hsucc, hrec] at hc
+
+theorem natRulePattern_inventory :
+    NatGeneration.flatCtors.map NatGeneration.rulePattern =
+      [.iota ``Nat.rec 3 ``Nat.zero 0,
+       .iota ``Nat.rec 3 ``Nat.succ 1] :=
+  rfl
+
+theorem natFinalEnv_defeqs_iff (df : VDefEq) :
+    natFinalEnv.defeqs df ↔ df ∈ NatGeneration.generatedRules := by
+  simpa [VEnv.empty] using
+    (VInductDecl.BlockGenerationChecked.addInductBlockGeneration_defeqs
+      NatGeneration (base := VEnv.empty) (env₁ := natFinalEnv) (by rfl) df)
+
+theorem natFinalEnv_no_structEta (rule : VStructEta) :
+    ¬natFinalEnv.structEtas rule := by
+  change ¬False
+  intro h
+  exact h
+
+theorem natRule_registered {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    natFinalEnv.defeqs (NatGeneration.rule i constructor) := by
+  rw [natFinalEnv_defeqs_iff]
+  unfold VInductDecl.BlockGenerationChecked.generatedRules
+  have hmem : (constructor, i) ∈ NatGeneration.flatCtors.zipIdx := by
+    apply List.mem_of_getElem? (i := i)
+    rw [List.getElem?_zipIdx, hentry, Option.map_some, Nat.zero_add]
+  simpa using (List.mem_map_of_mem
+    (f := fun ic => NatGeneration.rule ic.2 ic.1) hmem)
+
+/-- Capture paths before they are embedded as `.var` nodes in `ruleRHS`. -/
+def natCapturePaths (constructor : NormalizedBlockCtor) :
+    List ((NatGeneration.rulePattern constructor).toPattern.Path) :=
+  ((Pattern.varNPaths (.const (NatGeneration.ruleRecName constructor))
+      (NatGeneration.ruleMajorArity constructor)).take
+    (InductiveFixtures.natDecl.nparams + NatGeneration.familyCount +
+      NatGeneration.minorCount)).map Sum.inl ++
+  ((Pattern.varNPaths (.const constructor.ctor.raw.name)
+      (NatGeneration.ruleArgArity constructor)).drop
+    InductiveFixtures.natDecl.nparams).map Sum.inr
+
+/-- The zero descriptor keeps all three recursor captures and has no
+constructor-field captures. -/
+theorem natZeroCapturePaths :
+    natCapturePaths NatGeneration.flatCtors[0] =
+      (Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl := by
+  rfl
+
+/-- The successor descriptor keeps all three recursor captures followed by
+its single constructor-field capture. -/
+theorem natSuccCapturePaths :
+    natCapturePaths NatGeneration.flatCtors[1] =
+      (Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl ++
+        (Pattern.varNPaths (.const ``Nat.succ) 1).map Sum.inr := by
+  rfl
+
+theorem natCapturePaths_map_var (constructor : NormalizedBlockCtor) :
+    (natCapturePaths constructor).map (fun path => Pattern.RHS.var path) =
+      NatGeneration.captureArgs constructor := by
+  simp [natCapturePaths,
+    VInductDecl.BlockGenerationChecked.captureArgs, List.map_map,
+    Function.comp_def]
+
+theorem natRuleRHS_tower {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    NatGeneration.ruleRHS natRuleClosure hentry =
+      Pattern.RHS.appN
+        (.fixed (NatGeneration.rule i constructor).rhs
+          (natRuleClosure.rhs_closed hentry))
+        ((natCapturePaths constructor).map fun path => .var path) := by
+  unfold VInductDecl.BlockGenerationChecked.ruleRHS
+  rw [natCapturePaths_map_var]
+
+theorem natPat_pattern {p : Pattern} {r : p.RHS × p.Check}
+    (H : NatPat p r) :
+    p = (SimplePattern.iota ``Nat.rec 3 ``Nat.zero 0).toPattern ∨
+      p = (SimplePattern.iota ``Nat.rec 3 ``Nat.succ 1).toPattern := by
+  cases H with
+  | @mk i constructor hentry =>
+    have hmem : constructor ∈ NatGeneration.flatCtors :=
+      List.mem_of_getElem? hentry
+    have hpattern : NatGeneration.rulePattern constructor ∈
+        [.iota ``Nat.rec 3 ``Nat.zero 0,
+         .iota ``Nat.rec 3 ``Nat.succ 1] := by
+      rw [← natRulePattern_inventory]
+      exact List.mem_map_of_mem hmem
+    simp only [List.mem_cons, List.not_mem_nil, or_false] at hpattern
+    exact hpattern.imp (congrArg SimplePattern.toPattern)
+      (congrArg SimplePattern.toPattern)
+
+theorem natPat_wf {p : Pattern} {r : p.RHS × p.Check}
+    (H : NatPat p r) : p.WF natClassify := by
+  cases H with
+  | @mk i constructor hentry =>
+    have hmem : constructor ∈ NatGeneration.flatCtors :=
+      List.mem_of_getElem? hentry
+    have hpattern : NatGeneration.rulePattern constructor ∈
+        [.iota ``Nat.rec 3 ``Nat.zero 0,
+         .iota ``Nat.rec 3 ``Nat.succ 1] := by
+      rw [← natRulePattern_inventory]
+      exact List.mem_map_of_mem hmem
+    simp only [List.mem_cons, List.not_mem_nil, or_false] at hpattern
+    rcases hpattern with hpattern | hpattern <;> rw [hpattern]
+    · simp [SimplePattern.toPattern, Pattern.varN, Pattern.WF, natClassify]
+    · simp [SimplePattern.toPattern, Pattern.varN, Pattern.WF, natClassify]
+
+theorem d0Pat_simple {p : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) : ∃ sp : SimplePattern, p = sp.toPattern := by
+  cases H with
+  | iota H =>
+    exact VInductDecl.BlockGenerationChecked.IotaPat.pat_simple
+      NatGeneration H
+  | defn => exact ⟨.defn d0DefVal.name, rfl⟩
+
+theorem d0Pat_wf {p : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) : p.WF d0Classify := by
+  cases H with
+  | iota H =>
+    rcases natPat_pattern H with hp | hp <;> subst p <;>
+      simp [SimplePattern.toPattern, Pattern.WF, d0Classify, natClassify,
+        d0DefVal]
+  | defn => simp [Pattern.WF, d0Classify]
+
+/-- The fresh D0 definition head cannot intersect any subpattern of either
+generated Nat iota rule. -/
+theorem d0Def_inter_natSubpattern_none {p p' : Pattern}
+    {r : p.RHS × p.Check} (H : NatPat p r)
+    (hsub : Subpattern p' p) :
+    (Pattern.const d0DefVal.name).inter p' = none := by
+  rcases natPat_pattern H with hp | hp
+  · subst p
+    rcases RecursorIotaPattern.subpattern_inv hsub with
+      rfl | ⟨j, -, rfl⟩ | ⟨j, -, rfl⟩
+    · rfl
+    · simpa only [Pattern.varN] using
+        Pattern.varN_const_inter_of_ne_name d0Def_name_ne_natRec 0 j
+    · simpa only [Pattern.varN] using
+        Pattern.varN_const_inter_of_ne_name d0Def_name_ne_natZero 0 j
+  · subst p
+    rcases RecursorIotaPattern.subpattern_inv hsub with
+      rfl | ⟨j, -, rfl⟩ | ⟨j, -, rfl⟩
+    · rfl
+    · simpa only [Pattern.varN] using
+        Pattern.varN_const_inter_of_ne_name d0Def_name_ne_natRec 0 j
+    · simpa only [Pattern.varN] using
+        Pattern.varN_const_inter_of_ne_name d0Def_name_ne_natSucc 0 j
+
+theorem d0Pat_uniq {p₁ p₂ p₃ p₄ : Pattern}
+    {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check}
+    (H1 : D0Pat p₁ r) (H2 : D0Pat p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by
+  cases H1 with
+  | iota H1 =>
+    cases H2 with
+    | iota H2 =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq
+        NatGeneration H1 H2 H3 H4
+    | defn =>
+      rw [d0Def_inter_natSubpattern_none H1 H3] at H4
+      cases H4
+  | defn =>
+    cases H2 with
+    | iota H2 =>
+      cases H3
+      rw [Pattern.inter_comm,
+        d0Def_inter_natSubpattern_none H2 (Subpattern.refl)] at H4
+      cases H4
+    | defn =>
+      cases H3
+      simp [Pattern.inter] at H4
+      subst p₄
+      exact ⟨rfl, rfl, HEq.rfl⟩
+
+theorem d0Pat_app_l {p : Pattern} {r : p.RHS × p.Check}
+    {p₁ p₂ p₃ p₄ : Pattern}
+    (H : D0Pat p r) (h : Subpattern (.app p₁ p₂) p) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  cases H with
+  | iota H =>
+    exact VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l
+      NatGeneration H h
+  | defn => cases h
+
+theorem d0Pat_app_l_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : D0Pat p r) (H' : D0Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases H with
+  | iota H =>
+    cases H' with
+    | iota H' =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq
+        NatGeneration H H' h h' h₃
+    | defn => cases h'
+  | defn => cases h
+
+theorem d0Pat_app_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : D0Pat p r) (H' : D0Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases H with
+  | iota H =>
+    cases H' with
+    | iota H' =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq
+        NatGeneration H H' h h' h₃ h₃'
+    | defn => cases h'
+  | defn => cases h
+
+/-- Reading the canonical paths of an SExpr `varN` match returns its
+application arguments in application order. -/
+theorem matchesS_varN_paths [Params] {c : Name} {ls : List SLevel} :
+    ∀ (n : Nat) (args : List SExpr)
+      {mcap : (Pattern.varN (.const c) n).Path → SExpr},
+      (Pattern.varN (.const c) n).MatchesS
+        (args.foldl (fun f a => f.app a) (.const c ls)) ls mcap →
+      args.length = n →
+      (Pattern.varNPaths (.const c) n).map mcap = args := by
+  intro n
+  induction n with
+  | zero =>
+    intro args mcap H hlen
+    obtain rfl : args = [] := List.length_eq_zero_iff.mp hlen
+    rfl
+  | succ n ih =>
+    intro args mcap H hlen
+    have hne : args ≠ [] := by rintro rfl; simp at hlen
+    obtain ⟨args', arg, rfl⟩ : ∃ args' arg, args = args' ++ [arg] :=
+      ⟨args.dropLast, args.getLast hne,
+        (List.dropLast_concat_getLast hne).symm⟩
+    have hlen' : args'.length = n := by simpa using hlen
+    simp only [List.foldl_append, List.foldl_cons, List.foldl_nil] at H
+    cases H with
+    | var H =>
+      show ((Pattern.varNPaths (.const c) n).map some ++ [none]).map _ =
+        args' ++ [arg]
+      rw [List.map_append, List.map_map]
+      exact congrArg (fun xs => xs ++ [arg]) (ih args' H hlen')
+
+/-- Split an SExpr into its non-application head and application-order
+spine. -/
+def sexprSpine [Params] : SExpr → SExpr × List SExpr
+  | .app f a =>
+    let (head, args) := sexprSpine f
+    (head, args ++ [a])
+  | e => (e, [])
+
+theorem sexprSpine_foldl [Params] (f : SExpr) (args : List SExpr) :
+    sexprSpine (args.foldl (fun f a => f.app a) f) =
+      (match sexprSpine f with
+      | (head, pre) => (head, pre ++ args)) := by
+  induction args generalizing f with
+  | nil => simp
+  | cons arg args ih =>
+    rw [List.foldl_cons, ih]
+    simp [sexprSpine, List.append_assoc]
+
+theorem constFoldl_inj [Params] {c : Name} {ls ls' : List SLevel}
+    {xs ys : List SExpr}
+    (h : xs.foldl (fun (f a : SExpr) => f.app a) (SExpr.const c ls) =
+      ys.foldl (fun (f a : SExpr) => f.app a) (SExpr.const c ls')) :
+    ls = ls' ∧ xs = ys := by
+  have hs := congrArg sexprSpine h
+  rw [sexprSpine_foldl, sexprSpine_foldl] at hs
+  have hhead := congrArg (fun pair => pair.1) hs
+  have hargs := congrArg (fun pair => pair.2) hs
+  constructor
+  · injection hhead
+  · simpa [sexprSpine] using hargs
+
+/-- A concrete constant-headed `varN` match both fixes the spine length and
+reads its captures back in application order. -/
+theorem matchesS_varN_foldr [Params] {c : Name}
+    {exprLs matchLs : List SLevel}
+    {n : Nat} {args : List SExpr}
+    {mcap : (Pattern.varN (.const c) n).Path → SExpr}
+    (H : (Pattern.varN (.const c) n).MatchesS
+      (args.foldr (fun a f => f.app a) (.const c exprLs)) matchLs mcap) :
+    exprLs = matchLs ∧ args.length = n ∧
+      (Pattern.varNPaths (.const c) n).map mcap = args.reverse := by
+  obtain ⟨args', hlen, heq, H'⟩ := H.varN_const_inv
+  have heq' :
+      args.reverse.foldl (fun (f a : SExpr) => f.app a)
+          (SExpr.const c exprLs) =
+        args'.reverse.foldl (fun (f a : SExpr) => f.app a)
+          (SExpr.const c matchLs) := by
+    rw [List.foldl_reverse, List.foldl_reverse]
+    exact heq
+  obtain ⟨hlevels, hargs⟩ := constFoldl_inj heq'
+  refine ⟨hlevels, ?_, ?_⟩
+  · calc
+      args.length = args.reverse.length := by simp
+      _ = args'.reverse.length := congrArg List.length hargs
+      _ = args'.length := by simp
+      _ = n := hlen
+  · have H'' : (Pattern.varN (.const c) n).MatchesS
+        (args'.reverse.foldl (fun f a => f.app a) (.const c matchLs)) matchLs mcap := by
+      simpa only [List.foldl_reverse] using H'
+    rw [matchesS_varN_paths n args'.reverse H'' (by simpa using hlen)]
+    exact hargs.symm
+
+/-- Split an RHS syntax tree into its non-application head and left-to-right
+application spine. -/
+def rhsSpine {p : Pattern} : p.RHS → p.RHS × List p.RHS
+  | r@(.fixed ..) | r@(.var ..) => (r, [])
+  | .app f a =>
+    let (head, args) := rhsSpine f
+    (head, args ++ [a])
+
+theorem rhsSpine_appN {p : Pattern} (f : p.RHS) (args : List p.RHS) :
+    rhsSpine (Pattern.RHS.appN f args) =
+      (match rhsSpine f with
+      | (head, pre) => (head, pre ++ args)) := by
+  induction args generalizing f with
+  | nil => simp [Pattern.RHS.appN]
+  | cons arg args ih =>
+    rw [Pattern.RHS.appN]
+    rw [ih]
+    simp [rhsSpine, List.append_assoc]
+
+/-- A fixed-headed RHS application tower is injective in both its fixed
+VExpr head and its ordered path arguments. -/
+theorem rhsFixedAppN_inj {p : Pattern} {f g : VExpr}
+    {hf : f.Closed} {hg : g.Closed} {xs ys : List p.Path}
+    (h : Pattern.RHS.appN (.fixed f hf) (xs.map .var) =
+      Pattern.RHS.appN (.fixed g hg) (ys.map .var)) :
+    f = g ∧ xs = ys := by
+  have hs := congrArg rhsSpine h
+  rw [rhsSpine_appN, rhsSpine_appN] at hs
+  simp only [rhsSpine, List.nil_append] at hs
+  have hhead := congrArg (fun pair => pair.1) hs
+  have hargs := congrArg (fun pair => pair.2) hs
+  constructor
+  · injection hhead
+  · exact (List.map_inj_right
+      (fun _ _ hvar => Pattern.RHS.var.inj hvar)).mp hargs
+
+/-- The structural half of the D0 integration fixture.  `univs` remains a
+parameter because the Nat environment itself is closed and the experimental
+judgment deliberately supports arbitrary ambient universe valuations. -/
+def natParams (univs : Nat) : Params where
+  env := natFinalEnv
+  henv := natFinalEnv_ordered
+  univs := univs
+  Pat := NatPat
+  classify := natClassify
+  pat_simple :=
+    VInductDecl.BlockGenerationChecked.IotaPat.pat_simple NatGeneration
+  pat_wf := natPat_wf
+  pat_uniq :=
+    VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+  pat_app_l :=
+    VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l NatGeneration
+  pat_app_l_uniq :=
+    VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq NatGeneration
+  pat_app_uniq :=
+    VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq NatGeneration
+
+/-- The complete D0b structural instance.  It preserves the generated Nat
+inventory and adds the one fresh definition pattern. -/
+def d0Params (univs : Nat) : Params where
+  env := d0Env
+  henv := d0Env_ordered
+  univs := univs
+  Pat := D0Pat
+  classify := d0Classify
+  pat_simple := d0Pat_simple
+  pat_wf := d0Pat_wf
+  pat_uniq := d0Pat_uniq
+  pat_app_l := d0Pat_app_l
+  pat_app_l_uniq := d0Pat_app_l_uniq
+  pat_app_uniq := d0Pat_app_uniq
+
+/-! ## D0a-to-D0b proof transport
+
+`SExpr` retains its complete `Params` value as an inductive parameter.  D0
+transport is therefore an explicit syntax map (developed below), not a cast
+based only on the shared universe count. -/
+
+def natToD0Level (univs : Nat)
+    (u : @SLevel (natParams univs)) : @SLevel (d0Params univs) := by
+  refine ⟨u.1, ?_⟩
+  obtain ⟨l, hl, heval⟩ := u.2
+  refine ⟨l, ?_, heval⟩
+  change l.WF univs
+  change l.WF univs at hl
+  exact hl
+
+def d0ToNatLevel (univs : Nat)
+    (u : @SLevel (d0Params univs)) : @SLevel (natParams univs) := by
+  refine ⟨u.1, ?_⟩
+  obtain ⟨l, hl, heval⟩ := u.2
+  refine ⟨l, ?_, heval⟩
+  change l.WF univs
+  change l.WF univs at hl
+  exact hl
+
+@[simp] theorem d0ToNatLevel_natToD0Level (univs : Nat)
+    (u : @SLevel (natParams univs)) :
+    d0ToNatLevel univs (natToD0Level univs u) = u := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem natToD0Level_d0ToNatLevel (univs : Nat)
+    (u : @SLevel (d0Params univs)) :
+    natToD0Level univs (d0ToNatLevel univs u) = u := by
+  apply Subtype.ext
+  rfl
+
+noncomputable def natToD0Expr (univs : Nat) (e : @SExpr (natParams univs)) :
+    @SExpr (d0Params univs) :=
+  @SExpr.rec (natParams univs)
+    (motive := fun _ => @SExpr (d0Params univs))
+    (fun i => @SExpr.bvar (d0Params univs) i)
+    (fun u => @SExpr.sort (d0Params univs) (natToD0Level univs u))
+    (fun c ls => @SExpr.const (d0Params univs) c
+      (ls.map (natToD0Level univs)))
+    (fun _ _ f a => @SExpr.app (d0Params univs) f a)
+    (fun _ _ A body => @SExpr.lam (d0Params univs) A body)
+    (fun _ _ A B => @SExpr.forallE (d0Params univs) A B)
+    e
+
+noncomputable def d0ToNatExpr (univs : Nat) (e : @SExpr (d0Params univs)) :
+    @SExpr (natParams univs) :=
+  @SExpr.rec (d0Params univs)
+    (motive := fun _ => @SExpr (natParams univs))
+    (fun i => @SExpr.bvar (natParams univs) i)
+    (fun u => @SExpr.sort (natParams univs) (d0ToNatLevel univs u))
+    (fun c ls => @SExpr.const (natParams univs) c
+      (ls.map (d0ToNatLevel univs)))
+    (fun _ _ f a => @SExpr.app (natParams univs) f a)
+    (fun _ _ A body => @SExpr.lam (natParams univs) A body)
+    (fun _ _ A B => @SExpr.forallE (natParams univs) A B)
+    e
+
+@[simp] theorem natToD0Expr_bvar (univs i) :
+    natToD0Expr univs (@SExpr.bvar (natParams univs) i) =
+      @SExpr.bvar (d0Params univs) i := rfl
+
+@[simp] theorem natToD0Expr_sort (univs) (u : @SLevel (natParams univs)) :
+    natToD0Expr univs (@SExpr.sort (natParams univs) u) =
+      @SExpr.sort (d0Params univs) (natToD0Level univs u) := rfl
+
+@[simp] theorem natToD0Expr_const (univs c)
+    (ls : List (@SLevel (natParams univs))) :
+    natToD0Expr univs (@SExpr.const (natParams univs) c ls) =
+      @SExpr.const (d0Params univs) c (ls.map (natToD0Level univs)) := rfl
+
+@[simp] theorem natToD0Expr_app (univs)
+    (f a : @SExpr (natParams univs)) :
+    natToD0Expr univs (@SExpr.app (natParams univs) f a) =
+      @SExpr.app (d0Params univs) (natToD0Expr univs f)
+        (natToD0Expr univs a) := rfl
+
+@[simp] theorem natToD0Expr_lam (univs)
+    (A e : @SExpr (natParams univs)) :
+    natToD0Expr univs (@SExpr.lam (natParams univs) A e) =
+      @SExpr.lam (d0Params univs) (natToD0Expr univs A)
+        (natToD0Expr univs e) := rfl
+
+@[simp] theorem natToD0Expr_forallE (univs)
+    (A B : @SExpr (natParams univs)) :
+    natToD0Expr univs (@SExpr.forallE (natParams univs) A B) =
+      @SExpr.forallE (d0Params univs) (natToD0Expr univs A)
+        (natToD0Expr univs B) := rfl
+
+@[simp] theorem d0ToNatExpr_bvar (univs i) :
+    d0ToNatExpr univs (@SExpr.bvar (d0Params univs) i) =
+      @SExpr.bvar (natParams univs) i := rfl
+
+@[simp] theorem d0ToNatExpr_sort (univs) (u : @SLevel (d0Params univs)) :
+    d0ToNatExpr univs (@SExpr.sort (d0Params univs) u) =
+      @SExpr.sort (natParams univs) (d0ToNatLevel univs u) := rfl
+
+@[simp] theorem d0ToNatExpr_const (univs c)
+    (ls : List (@SLevel (d0Params univs))) :
+    d0ToNatExpr univs (@SExpr.const (d0Params univs) c ls) =
+      @SExpr.const (natParams univs) c (ls.map (d0ToNatLevel univs)) := rfl
+
+@[simp] theorem d0ToNatExpr_app (univs)
+    (f a : @SExpr (d0Params univs)) :
+    d0ToNatExpr univs (@SExpr.app (d0Params univs) f a) =
+      @SExpr.app (natParams univs) (d0ToNatExpr univs f)
+        (d0ToNatExpr univs a) := rfl
+
+@[simp] theorem d0ToNatExpr_lam (univs)
+    (A e : @SExpr (d0Params univs)) :
+    d0ToNatExpr univs (@SExpr.lam (d0Params univs) A e) =
+      @SExpr.lam (natParams univs) (d0ToNatExpr univs A)
+        (d0ToNatExpr univs e) := rfl
+
+@[simp] theorem d0ToNatExpr_forallE (univs)
+    (A B : @SExpr (d0Params univs)) :
+    d0ToNatExpr univs (@SExpr.forallE (d0Params univs) A B) =
+      @SExpr.forallE (natParams univs) (d0ToNatExpr univs A)
+        (d0ToNatExpr univs B) := rfl
+
+
+@[simp] theorem d0ToNatExpr_natToD0Expr (univs : Nat)
+    (e : @SExpr (natParams univs)) :
+    d0ToNatExpr univs (natToD0Expr univs e) = e := by
+  induction e <;> simp [List.map_map, Function.comp_def, *]
+
+@[simp] theorem natToD0Expr_d0ToNatExpr (univs : Nat)
+    (e : @SExpr (d0Params univs)) :
+    natToD0Expr univs (d0ToNatExpr univs e) = e := by
+  induction e <;> simp [List.map_map, Function.comp_def, *]
+
+noncomputable def natToD0Subst (univs : Nat) (sigma : @Subst (natParams univs)) :
+    @Subst (d0Params univs) := fun i => natToD0Expr univs (sigma i)
+
+@[simp] theorem natToD0Expr_lift' (univs : Nat)
+    (e : @SExpr (natParams univs)) (rho : Lift) :
+    natToD0Expr univs (@SExpr.lift' (natParams univs) e rho) =
+      @SExpr.lift' (d0Params univs) (natToD0Expr univs e) rho := by
+  induction e generalizing rho <;> simp [SExpr.lift', *]
+
+@[simp] theorem natToD0Subst_lift (univs : Nat)
+    (sigma : @Subst (natParams univs)) :
+    natToD0Subst univs (@Subst.lift (natParams univs) sigma) =
+      @Subst.lift (d0Params univs) (natToD0Subst univs sigma) := by
+  funext i
+  cases i <;> simp [natToD0Subst, Subst.lift,
+    natToD0Expr_lift']
+
+@[simp] theorem natToD0Expr_subst (univs : Nat)
+    (e : @SExpr (natParams univs)) (sigma : @Subst (natParams univs)) :
+    natToD0Expr univs (@SExpr.subst (natParams univs) e sigma) =
+      @SExpr.subst (d0Params univs) (natToD0Expr univs e)
+        (natToD0Subst univs sigma) := by
+  induction e generalizing sigma <;>
+    simp [SExpr.subst, natToD0Subst, *]
+
+@[simp] theorem natToD0Expr_inst (univs : Nat)
+    (e a : @SExpr (natParams univs)) :
+    natToD0Expr univs (@SExpr.inst (natParams univs) e a) =
+      @SExpr.inst (d0Params univs) (natToD0Expr univs e)
+        (natToD0Expr univs a) := by
+  change natToD0Expr univs
+      (@SExpr.subst (natParams univs) e (@Subst.one (natParams univs) a)) =
+    @SExpr.subst (d0Params univs) (natToD0Expr univs e)
+      (@Subst.one (d0Params univs) (natToD0Expr univs a))
+  rw [natToD0Expr_subst]
+  congr 1
+  funext i
+  cases i <;> rfl
+
+@[simp] theorem natToD0Level_instV (univs : Nat)
+    (ls : List (@SLevel (natParams univs))) (u : VLevel) :
+    natToD0Level univs (@SLevel.instV (natParams univs) ls u) =
+      @SLevel.instV (d0Params univs) (ls.map (natToD0Level univs)) u := by
+  apply Subtype.ext
+  funext v
+  change u.eval (ls.map fun l => l.1 v) =
+    u.eval ((ls.map (natToD0Level univs)).map fun l => l.1 v)
+  congr 1
+  simp [List.map_map, Function.comp_def, natToD0Level]
+
+@[simp] theorem natToD0Level_succ (univs : Nat)
+    (u : @SLevel (natParams univs)) :
+    natToD0Level univs (@SLevel.succ (natParams univs) u) =
+      @SLevel.succ (d0Params univs) (natToD0Level univs u) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem natToD0Level_imax (univs : Nat)
+    (u v : @SLevel (natParams univs)) :
+    natToD0Level univs (@SLevel.imax (natParams univs) u v) =
+      @SLevel.imax (d0Params univs)
+        (natToD0Level univs u) (natToD0Level univs v) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem natToD0Expr_mkInst (univs : Nat)
+    (ls : List (@SLevel (natParams univs))) (e : VExpr) :
+    natToD0Expr univs (@SExpr.mkInst (natParams univs) ls e) =
+      @SExpr.mkInst (d0Params univs) (ls.map (natToD0Level univs)) e := by
+  induction e <;> simp [SExpr.mkInst, List.map_map, Function.comp_def, *]
+
+theorem natLookup_to_d0 (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))} {i : Nat}
+    {A : @SExpr (natParams univs)}
+    (H : @Lookup (natParams univs) Gamma i A) :
+    @Lookup (d0Params univs) (Gamma.map (natToD0Expr univs)) i
+      (natToD0Expr univs A) := by
+  letI : Params := d0Params univs
+  induction H with
+  | zero =>
+    rw [natToD0Expr_lift']
+    exact .zero
+  | succ _ ih =>
+    rw [natToD0Expr_lift']
+    exact .succ ih
+
+theorem natIsDefEq_to_d0 (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {e₁ e₂ A : @SExpr (natParams univs)}
+    (H : @IsDefEq (natParams univs) Gamma e₁ e₂ A) :
+    @IsDefEq (d0Params univs) (Gamma.map (natToD0Expr univs))
+      (natToD0Expr univs e₁) (natToD0Expr univs e₂)
+      (natToD0Expr univs A) := by
+  letI : Params := d0Params univs
+  induction H with
+  | bvar h => exact .bvar (natLookup_to_d0 univs h)
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [natToD0Expr_sort, natToD0Level_succ] using
+      (IsDefEq.sort : IsDefEq (Gamma.map (natToD0Expr univs))
+        (.sort (natToD0Level univs l)) (.sort (natToD0Level univs l))
+        (.sort (.succ (natToD0Level univs l))))
+  | @const c ci Gamma ls hreg hlen =>
+    simpa only [natToD0Expr_const, natToD0Expr_mkInst] using
+      (IsDefEq.const (Γ := Gamma.map (natToD0Expr univs))
+        (ls := ls.map (natToD0Level univs))
+        (natFinalEnv_le_d0Env.constants hreg) (by simpa using hlen))
+  | appDF _ _ ihf iha =>
+    rw [natToD0Expr_app, natToD0Expr_app, natToD0Expr_inst]
+    exact IsDefEq.appDF ihf iha
+  | lamDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, natToD0Expr_lam, natToD0Expr_forallE] using
+      IsDefEq.lamDF ihA ihBody
+  | forallEDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, natToD0Expr_forallE, natToD0Expr_sort,
+      natToD0Level_imax] using IsDefEq.forallEDF ihA ihBody
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ ihBody ihArg =>
+    simpa only [List.map_cons, natToD0Expr_app, natToD0Expr_lam,
+      natToD0Expr_inst] using
+      IsDefEq.beta ihBody ihArg
+  | eta _ ih =>
+    rw [natToD0Expr_lam, natToD0Expr_app, natToD0Expr_bvar,
+      natToD0Expr_forallE, natToD0Expr_lift']
+    exact IsDefEq.eta ih
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @extra df Gamma ls hreg hlen =>
+    simpa only [natToD0Expr_mkInst] using
+      (IsDefEq.extra (Γ := Gamma.map (natToD0Expr univs))
+        (ls := ls.map (natToD0Level univs))
+        (natFinalEnv_le_d0Env.defeqs hreg) (by simpa using hlen))
+
+theorem natClassify_d0Def_none : natClassify d0DefVal.name = none := by
+  native_decide
+
+/-- A constructor-shaped D0b classification cannot be the new definition,
+and therefore determines the same constructor classification in D0a. -/
+theorem d0CtorToNat (univs : Nat) {c : Name}
+    (H : @CtorBundle.IsCtor (d0Params univs) c) :
+    @CtorBundle.IsCtor (natParams univs) c := by
+  change ∃ cl, d0Classify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true at H
+  change ∃ cl, natClassify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true
+  obtain ⟨cl, hclass, hshape⟩ := H
+  have hne : c ≠ d0DefVal.name := by
+    intro hc
+    subst c
+    simp [d0Classify] at hclass
+    subst cl
+    simp at hshape
+  exact ⟨cl, by simpa [d0Classify, hne] using hclass, hshape⟩
+
+theorem natIndTyClassify_to_d0 {c : Name} {arity : Nat}
+    (H : natClassify c = some (.indTy arity)) :
+    d0Classify c = some (.indTy arity) := by
+  have hne : c ≠ d0DefVal.name := by
+    intro hc
+    subst c
+    rw [natClassify_d0Def_none] at H
+    cases H
+  simpa [d0Classify, hne] using H
+
+theorem d0CtorToNat_cl_eq (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d0Params univs) c) :
+    (@CtorBundle.IsCtor.cl (natParams univs) c (d0CtorToNat univs cl)).1 =
+      (@CtorBundle.IsCtor.cl (d0Params univs) c cl).1 := by
+  let oldCl := @CtorBundle.IsCtor.cl (natParams univs) c
+    (d0CtorToNat univs cl)
+  let newCl := @CtorBundle.IsCtor.cl (d0Params univs) c cl
+  have hne : c ≠ d0DefVal.name := by
+    intro hc
+    subst c
+    have hold := oldCl.2.1
+    change natClassify d0DefVal.name = some oldCl.1 at hold
+    rw [natClassify_d0Def_none] at hold
+    cases hold
+  have hnewNat : natClassify c = some newCl.1 := by
+    have hnew := newCl.2.1
+    change d0Classify c = some newCl.1 at hnew
+    simpa [d0Classify, hne] using hnew
+  have hold := oldCl.2.1
+  change natClassify c = some oldCl.1 at hold
+  exact Option.some.inj (hold.symm.trans hnewNat)
+
+/-- Reindex a D0a constructor bundle through the syntax and classifier
+maps. -/
+noncomputable def natCtorBundleToD0 (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d0Params univs) c)
+    (F : @CtorBundle (natParams univs) c (d0CtorToNat univs cl)) :
+    @CtorBundle (d0Params univs) c cl := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  refine @CtorBundle.mk (d0Params univs) c cl I
+    (Ts.map (natToD0Expr univs)) (args.map (natToD0Expr univs))
+    (natToD0Level univs u) ?_ ?_ ?_
+  · rw [List.length_map, hlen, d0CtorToNat_cl_eq univs cl]
+  · change natClassify I = some (.indTy args.length) at hclI
+    letI : Params := d0Params univs
+    change d0Classify I = some (.indTy (args.map (natToD0Expr univs)).length)
+    simpa using natIndTyClassify_to_d0 hclI
+  · intro hzero
+    have hback := congrArg (d0ToNatLevel univs) hzero
+    apply hu0
+    apply Subtype.ext
+    exact congrArg Subtype.val hback
+
+theorem natToD0Expr_foldr_forallE (univs : Nat)
+    (Ts : List (@SExpr (natParams univs))) (e : @SExpr (natParams univs)) :
+    natToD0Expr univs
+        (Ts.foldr (fun A B => @SExpr.forallE (natParams univs) A B) e) =
+      (Ts.map (natToD0Expr univs)).foldr
+        (fun A B => @SExpr.forallE (d0Params univs) A B)
+        (natToD0Expr univs e) := by
+  induction Ts <;> simp [*]
+
+theorem natToD0Expr_foldr_app (univs : Nat)
+    (args : List (@SExpr (natParams univs)))
+    (e : @SExpr (natParams univs)) :
+    natToD0Expr univs
+        (args.foldr (fun A acc => @SExpr.app (natParams univs) acc A) e) =
+      (args.map (natToD0Expr univs)).foldr
+        (fun A acc => @SExpr.app (d0Params univs) acc A)
+        (natToD0Expr univs e) := by
+  induction args <;> simp [*]
+
+@[simp] theorem natCtorBundleToD0_rhs (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d0Params univs) c)
+    (F : @CtorBundle (natParams univs) c (d0CtorToNat univs cl))
+    (ls : List (@SLevel (natParams univs))) :
+    natToD0Expr univs (@CtorBundle.rhs (natParams univs) c
+      (d0CtorToNat univs cl) F ls) =
+      @CtorBundle.rhs (d0Params univs) c cl
+        (natCtorBundleToD0 univs cl F)
+        (ls.map (natToD0Level univs)) := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  simp [CtorBundle.rhs, natCtorBundleToD0,
+    natToD0Expr_foldr_forallE, natToD0Expr_foldr_app]
+
+@[simp] theorem natCtorBundleToD0_u (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d0Params univs) c)
+    (F : @CtorBundle (natParams univs) c (d0CtorToNat univs cl)) :
+    @CtorBundle.u (d0Params univs) c cl
+        (natCtorBundleToD0 univs cl F) =
+      natToD0Level univs
+        (@CtorBundle.u (natParams univs) c (d0CtorToNat univs cl) F) := by
+  cases F
+  rfl
+
+@[simp] theorem natToD0Expr_rhs_applyS (univs : Nat) {p : Pattern}
+    (r : p.RHS) (m₁ : List (@SLevel (natParams univs)))
+    (m₂ : p.Path → @SExpr (natParams univs)) :
+    natToD0Expr univs
+        (@Pattern.RHS.applyS (natParams univs) p m₁ m₂ r) =
+      @Pattern.RHS.applyS (d0Params univs) p
+        (m₁.map (natToD0Level univs))
+        (fun path => natToD0Expr univs (m₂ path)) r := by
+  induction r with
+  | fixed e closed => exact natToD0Expr_mkInst univs m₁ e
+  | var path => rfl
+  | app f a ihf iha =>
+    simp only [Pattern.RHS.applyS, natToD0Expr_app, ihf, iha]
+
+theorem natMatchesS_to_d0 (univs : Nat) {p : Pattern}
+    {e : @SExpr (natParams univs)}
+    {m₁ : List (@SLevel (natParams univs))}
+    {m₂ : p.Path → @SExpr (natParams univs)}
+    (H : @Pattern.MatchesS (natParams univs) p e m₁ m₂) :
+    @Pattern.MatchesS (d0Params univs) p (natToD0Expr univs e)
+      (m₁.map (natToD0Level univs))
+      (fun path => natToD0Expr univs (m₂ path)) := by
+  letI : Params := d0Params univs
+  induction H with
+  | @const c ls =>
+    rw [natToD0Expr_const]
+    refine cast ?_ (@Pattern.MatchesS.const (d0Params univs) c
+      (ls.map (natToD0Level univs)))
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f₁ g₁ a' _ ih =>
+    change @Pattern.MatchesS (d0Params univs) (.var f)
+      (.app (natToD0Expr univs f') (natToD0Expr univs a'))
+      (f₁.map (natToD0Level univs))
+      (fun path => natToD0Expr univs (Option.elim path a' g₁))
+    have heq : (fun path => natToD0Expr univs (Option.elim path a' g₁)) =
+        (fun path => Option.elim path (natToD0Expr univs a')
+          (fun path => natToD0Expr univs (g₁ path))) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f₁ g₁ a a' f₂ g₂ _ _ ihf iha =>
+    change @Pattern.MatchesS (d0Params univs) (.app f a)
+      (@SExpr.app (d0Params univs)
+        (natToD0Expr univs f') (natToD0Expr univs a'))
+      (f₁.map (natToD0Level univs))
+      (fun path => natToD0Expr univs (Sum.elim g₁ g₂ path))
+    have heq : (fun path => natToD0Expr univs (Sum.elim g₁ g₂ path)) =
+        Sum.elim (fun path => natToD0Expr univs (g₁ path))
+          (fun path => natToD0Expr univs (g₂ path)) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ihf.app iha
+
+theorem natToD0_defeqsS (univs : Nat) {p : Pattern}
+    (ck : p.Check) (m₁ : List (@SLevel (natParams univs)))
+    (m₂ : p.Path → @SExpr (natParams univs)) :
+    (@Pattern.Check.defeqsS (natParams univs) p m₁ m₂ ck).map
+        (fun ab => (natToD0Expr univs ab.1, natToD0Expr univs ab.2)) =
+      @Pattern.Check.defeqsS (d0Params univs) p
+        (m₁.map (natToD0Level univs))
+        (fun path => natToD0Expr univs (m₂ path)) ck := by
+  induction ck with
+  | true => rfl
+  | defeq a b rest ih =>
+    simp only [Pattern.Check.defeqsS, List.map_cons, ih,
+      natToD0Expr_rhs_applyS]
+
+noncomputable def natToD0Dfs (univs : Nat)
+    (dfs : List (@SExpr (natParams univs) × @SExpr (natParams univs) ×
+      @SExpr (natParams univs))) :
+    List (@SExpr (d0Params univs) × @SExpr (d0Params univs) ×
+      @SExpr (d0Params univs)) :=
+  dfs.map fun (B, a, b) =>
+    (natToD0Expr univs B, natToD0Expr univs a, natToD0Expr univs b)
+
+theorem natToD0Dfs_map_snd (univs : Nat)
+    (dfs : List (@SExpr (natParams univs) × @SExpr (natParams univs) ×
+      @SExpr (natParams univs))) :
+    (natToD0Dfs univs dfs).map (fun x => x.2) =
+      (dfs.map fun x => x.2).map fun ab =>
+        (natToD0Expr univs ab.1, natToD0Expr univs ab.2) := by
+  simp [natToD0Dfs, List.map_map, Function.comp_def]
+
+noncomputable def natAction_to_d0 (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))} {p : Pattern}
+    {r : p.RHS × p.Check} {e A : @SExpr (natParams univs)}
+    {m₁ : List (@SLevel (natParams univs))}
+    {m₂ : p.Path → @SExpr (natParams univs)}
+    (H : @Pattern.Action (natParams univs) Gamma p r e m₁ m₂ A) :
+    @Pattern.Action (d0Params univs)
+      (Gamma.map (natToD0Expr univs)) p r
+      (natToD0Expr univs e) (m₁.map (natToD0Level univs))
+      (fun path => natToD0Expr univs (m₂ path))
+      (natToD0Expr univs A) := by
+  rcases H with ⟨hpat, hmatched, dfs, hdefeqs, hchecked, hsound⟩
+  change NatPat p r at hpat
+  refine @Pattern.Action.mk (d0Params univs)
+    (Gamma := Gamma.map (natToD0Expr univs)) (p := p) (r := r)
+    (e := natToD0Expr univs e)
+    (m1 := m₁.map (natToD0Level univs))
+    (m2 := fun path => natToD0Expr univs (m₂ path))
+    (A := natToD0Expr univs A) (.iota hpat)
+    (natMatchesS_to_d0 univs hmatched) (natToD0Dfs univs dfs) ?_ ?_ ?_
+  · rw [natToD0Dfs_map_snd, hdefeqs]
+    exact natToD0_defeqsS univs r.2 m₁ m₂
+  · intro a b B hmem
+    simp only [natToD0Dfs, List.mem_map] at hmem
+    obtain ⟨⟨B₀, a₀, b₀⟩, hmem₀, heq⟩ := hmem
+    cases heq
+    exact natIsDefEq_to_d0 univs (hchecked a₀ b₀ B₀ hmem₀)
+  · simpa only [natToD0Expr_rhs_applyS] using
+      natIsDefEq_to_d0 univs hsound
+
+theorem d0Pat_at_old_const_false {c : Name} {ci : VConstant}
+    (hreg : natFinalEnv.constants c = some ci)
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : D0Pat (.const c) r) : False := by
+  cases H with
+  | iota H =>
+    rcases natPat_pattern H with h | h <;> cases h
+  | defn =>
+    rw [d0Def_fresh] at hreg
+    cases hreg
+
+/-- Transport a D0a evidence-rich derivation into the definition-extended
+D0b syntax and registry. -/
+noncomputable def natStrongToD0 (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {e₁ e₂ A : @SExpr (natParams univs)}
+    (H : @IsDefEqStrong (natParams univs) Gamma e₁ e₂ A) :
+    @IsDefEqStrong (d0Params univs) (Gamma.map (natToD0Expr univs))
+      (natToD0Expr univs e₁) (natToD0Expr univs e₂)
+      (natToD0Expr univs A) := by
+  letI : Params := d0Params univs
+  induction H with
+  | bvar h _ ihA => exact .bvar (natLookup_to_d0 univs h) ihA
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [natToD0Expr_sort, natToD0Level_succ] using
+      (IsDefEqStrong.sort : IsDefEqStrong
+        (Gamma.map (natToD0Expr univs))
+        (.sort (natToD0Level univs l)) (.sort (natToD0Level univs l))
+        (.sort (.succ (natToD0Level univs l))))
+  | @const c ci Gamma ls u hreg hlen hTy F hF hDef
+      ihTy ihF ihDef =>
+    let F' : ∀ cl : CtorBundle.IsCtor c, CtorBundle c cl := fun cl =>
+      natCtorBundleToD0 univs cl (F (d0CtorToNat univs cl))
+    simpa only [natToD0Expr_const, natToD0Expr_mkInst] using
+      (@IsDefEqStrong.const (d0Params univs) c ci
+      (Gamma.map (natToD0Expr univs))
+      (ls.map (natToD0Level univs)) (natToD0Level univs u)
+      (natFinalEnv_le_d0Env.constants hreg)
+      (by simpa only [List.length_map] using hlen) (by
+        simpa only [natToD0Expr_mkInst, natToD0Expr_sort] using ihTy)
+      F' (by
+        intro cl
+        dsimp only [F']
+        rw [← natCtorBundleToD0_rhs, natCtorBundleToD0_u]
+        have H := ihF (d0CtorToNat univs cl)
+        simp only [natToD0Expr_mkInst, natToD0Expr_sort] at H
+        exact H) (by
+        intro r hpat
+        exact (d0Pat_at_old_const_false hreg hpat).elim))
+  | appDF _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    rw [natToD0Expr_inst, natToD0Expr_inst, natToD0Expr_sort] at ihResult
+    simpa only [List.map_cons, natToD0Expr_app, natToD0Expr_forallE,
+      natToD0Expr_inst] using
+      IsDefEqStrong.appDF ihA ihCod ihf iha ihResult
+  | lamDF _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    simpa only [List.map_cons, natToD0Expr_lam, natToD0Expr_forallE] using
+      IsDefEqStrong.lamDF ihA ihB ihB' ihBody ihBody'
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    simpa only [List.map_cons, natToD0Expr_forallE, natToD0Expr_sort,
+      natToD0Level_imax] using
+      IsDefEqStrong.forallEDF ihA ihBody ihBody'
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    simp only [natToD0Expr_app, natToD0Expr_lam,
+      natToD0Expr_inst] at ihApp
+    simp only [natToD0Expr_inst] at ihInst
+    simpa only [List.map_cons, natToD0Expr_app, natToD0Expr_lam,
+      natToD0Expr_inst] using
+      IsDefEqStrong.beta ihBody ihArg ihApp ihInst
+  | @eta Gamma e A B _ _ ihTerm ihLam =>
+    rw [natToD0Expr_lam, natToD0Expr_app, natToD0Expr_lift',
+      natToD0Expr_bvar, natToD0Expr_forallE] at ihLam ⊢
+    exact IsDefEqStrong.eta ihTerm ihLam
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @defn c ci Gamma ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    have hpat : NatPat (.const c) r := by
+      change (natParams univs).Pat (.const c) r
+      exact @Pattern.Action.pat (natParams univs) Gamma (.const c) r
+        (@SExpr.const (natParams univs) c ls) ls Empty.elim
+        (@SExpr.mkInst (natParams univs) ls ci.type) action
+    rcases natPat_pattern hpat with h | h <;> cases h
+  | extra action _ _ ihLeft ihRight =>
+    rw [natToD0Expr_rhs_applyS] at ihRight
+    simpa only [natToD0Expr_rhs_applyS] using
+      IsDefEqStrong.extra (natAction_to_d0 univs action) ihLeft ihRight
+
+section SemanticCertificates
+
+/-- The Nat environment has no structure-eta registry entries, so its weak
+reflection bridge is vacuous. -/
+theorem natStructureEtaSound (univs : Nat) :
+    @Params.StructureEtaSound (natParams univs) := by
+  letI : Params := natParams univs
+  intro rule levels Gamma params major hreg
+  exact (natFinalEnv_no_structEta rule hreg).elim
+
+/-- Raw type uniqueness for the concrete Nat bridge.  The semantic syntax
+is reflected into the checked Theory environment, where uniqueness follows
+from `nat_env_wf`, then translated back through the level quotient. -/
+def NatContextValid (univs : Nat)
+    (Gamma : List (@SExpr (natParams univs))) : Prop :=
+  letI : Params := natParams univs
+  OnCtx (Gamma.map SExpr.reify) (natFinalEnv.IsType univs)
+
+def NatTypesDefEq (univs : Nat) {Gamma : List (@SExpr (natParams univs))}
+    (A B : @SExpr (natParams univs)) : Prop :=
+  letI : Params := natParams univs
+  ∃ u, IsDefEq Gamma A B (.sort u)
+
+theorem natTypeUniq (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))} {x A B : @SExpr (natParams univs)}
+    (hGamma : NatContextValid univs Gamma)
+    (hxA : @IsDefEq (natParams univs) Gamma x x A)
+    (hxB : @IsDefEq (natParams univs) Gamma x x B) :
+    NatTypesDefEq (Gamma := Gamma) univs A B := by
+  letI : Params := natParams univs
+  change OnCtx (Gamma.map SExpr.reify) (natFinalEnv.IsType univs) at hGamma
+  change ∃ u, IsDefEq Gamma A B (.sort u)
+  have hxA' := hxA.reify hGamma
+  have hxB' := hxB.reify hGamma
+  obtain ⟨u, hAB⟩ := hxA'.uniq InductiveReplayFixtures.nat_env_wf hGamma hxB'
+  have hlevels := (VEnv.CtxStrong.strong natFinalEnv_ordered hGamma).levelWF
+  have hAB' := SExpr.IsDefEq.mkS (natStructureEtaSound univs) hAB hlevels
+  have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  rw [hctx] at hAB'
+  refine ⟨SLevel.mk u, ?_⟩
+  simpa only [SExpr.mk_reify, SExpr.mk] using hAB'
+
+/-- Type equality in the concrete bridge composes even when its two raw
+derivations choose different sort representatives.  The middle type's two
+self-typings are aligned by `natTypeUniq` before ordinary homogeneous
+transitivity is used. -/
+theorem natTypesTrans (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {A B C : @SExpr (natParams univs)}
+    (hGamma : NatContextValid univs Gamma)
+    (hAB : NatTypesDefEq (Gamma := Gamma) univs A B)
+    (hBC : NatTypesDefEq (Gamma := Gamma) univs B C) :
+    NatTypesDefEq (Gamma := Gamma) univs A C := by
+  letI : Params := natParams univs
+  obtain ⟨u, hAB⟩ := hAB
+  obtain ⟨v, hBC⟩ := hBC
+  obtain ⟨w, huv⟩ := natTypeUniq univs hGamma hAB.hasType.2 hBC.hasType.1
+  exact ⟨u, hAB.trans (huv.symm.defeqDF hBC)⟩
+
+/-- Instantiate a type equality under one binder with a well-typed semantic
+argument. -/
+theorem natTypesInst (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B B' e : @SExpr (natParams univs)}
+    (hBB' : NatTypesDefEq (Gamma := D :: Gamma) univs B B')
+    (he : @IsDefEq (natParams univs) Gamma e e D) :
+    NatTypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (natParams univs) B e)
+      (@SExpr.inst (natParams univs) B' e) := by
+  letI : Params := natParams univs
+  obtain ⟨u, hBB'⟩ := hBB'
+  have hsubst := hBB'.subst
+    (Ctx.Subst.one IsDefEq.weak' IsDefEq.bvar he)
+  change IsDefEq Gamma (B.inst e) (B'.inst e) (.sort u) at hsubst
+  exact ⟨u, hsubst⟩
+
+/-- Pi injectivity for the concrete semantic syntax.  The raw SExpr
+equality is reflected into the checked Nat environment, decomposed there,
+and translated back. -/
+theorem natForallEInv (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {A B A' B' : @SExpr (natParams univs)}
+    (hGamma : NatContextValid univs Gamma)
+    (hPi : NatTypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (natParams univs) A B)
+      (@SExpr.forallE (natParams univs) A' B')) :
+    NatTypesDefEq (Gamma := Gamma) univs A A' ∧
+      NatTypesDefEq (Gamma := A :: Gamma) univs B B' := by
+  letI : Params := natParams univs
+  change OnCtx (Gamma.map SExpr.reify) (natFinalEnv.IsType univs) at hGamma
+  obtain ⟨_, hPi⟩ := hPi
+  have hPi' := hPi.reify hGamma
+  have hPiU : natFinalEnv.IsDefEqU univs (Gamma.map SExpr.reify)
+      (.forallE A.reify B.reify) (.forallE A'.reify B'.reify) := by
+    exact ⟨_, hPi'⟩
+  obtain ⟨⟨u, hA⟩, v, hB⟩ :=
+    VEnv.IsDefEqU.forallE_inv InductiveReplayFixtures.nat_env_wf hGamma hPiU
+  have hlevels :=
+    (VEnv.CtxStrong.strong natFinalEnv_ordered hGamma).levelWF
+  have hA' := SExpr.IsDefEq.mkS (natStructureEtaSound univs) hA hlevels
+  have hAlevels := (hA.levelWF hlevels).1
+  have hB' := SExpr.IsDefEq.mkS (natStructureEtaSound univs) hB
+    ⟨hlevels, hAlevels⟩
+  have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  constructor
+  · refine ⟨SLevel.mk u, ?_⟩
+    simpa only [hctx, SExpr.mk_reify, SExpr.mk] using hA'
+  · refine ⟨SLevel.mk v, ?_⟩
+    simpa only [List.map_cons, hctx, SExpr.mk_reify, SExpr.mk] using hB'
+
+/-- One exposed application layer of a conversion-aware spine, aligned with
+a concrete Pi type. -/
+structure NatSpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (D B e : @SExpr (natParams univs))
+    (es : List (@SExpr (natParams univs)))
+    (R : @SExpr (natParams univs)) where
+  domain : @SExpr (natParams univs)
+  codomain : @SExpr (natParams univs)
+  domainEq : NatTypesDefEq (Gamma := Gamma) univs D domain
+  codomainEq : NatTypesDefEq (Gamma := D :: Gamma) univs B codomain
+  argument : @IsDefEq (natParams univs) Gamma e e domain
+  tail : @SpineWF (natParams univs) Gamma
+    (@SExpr.inst (natParams univs) codomain e) es R
+
+/-- Peel the first argument of a `SpineWF`, commuting past its head and
+result conversions.  Pi injectivity supplies the dependent equality needed
+to keep the concrete generated telescope aligned with the exposed spine. -/
+theorem natSpineConsView_nonempty (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B Head e R : @SExpr (natParams univs)}
+    {es : List (@SExpr (natParams univs))}
+    (hGamma : NatContextValid univs Gamma)
+    (hHead : NatTypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (natParams univs) D B) Head)
+    (H : @SpineWF (natParams univs) Gamma Head (e :: es) R) :
+    Nonempty (NatSpineConsView (Gamma := Gamma) univs D B e es R) := by
+  letI : Params := natParams univs
+  generalize hargsEq : e :: es = args at H
+  induction H generalizing D B e es with
+  | nil => cases hargsEq
+  | @cons _ domain _ _ codomain harg htail ih =>
+    cases hargsEq
+    obtain ⟨hdom, hbody⟩ := natForallEInv univs hGamma hHead
+    exact ⟨{
+      domain := domain
+      codomain := codomain
+      domainEq := hdom
+      codomainEq := hbody
+      argument := harg
+      tail := htail }⟩
+  | @conv _ Head' u _ _ hconv htail ih =>
+    exact ih (natTypesTrans univs hGamma hHead ⟨u, hconv⟩) hargsEq
+  | @ret _ _ R' _ _ htail hret ih =>
+    let ⟨view⟩ := ih hHead hargsEq
+    exact ⟨{ view with tail := .ret view.tail hret }⟩
+
+/-- Data-valued first-layer view selected at the proposition-elimination
+boundary above. -/
+noncomputable def natSpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B Head e R : @SExpr (natParams univs)}
+    {es : List (@SExpr (natParams univs))}
+    (hGamma : NatContextValid univs Gamma)
+    (hHead : NatTypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (natParams univs) D B) Head)
+    (H : @SpineWF (natParams univs) Gamma Head (e :: es) R) :
+    NatSpineConsView (Gamma := Gamma) univs D B e es R :=
+  Classical.choice (natSpineConsView_nonempty univs hGamma hHead H)
+
+/-- The exposed argument also has the concrete generated domain. -/
+theorem NatSpineConsView.argumentExpected (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B e R : @SExpr (natParams univs)}
+    {es : List (@SExpr (natParams univs))}
+    (view : NatSpineConsView (Gamma := Gamma) univs D B e es R) :
+    @IsDefEq (natParams univs) Gamma e e D := by
+  letI : Params := natParams univs
+  obtain ⟨_, hdom⟩ := view.domainEq
+  exact hdom.symm.defeqDF view.argument
+
+/-- Equality between the concrete next telescope layer and the next head
+exposed by the caller's spine. -/
+theorem NatSpineConsView.restEq (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B e R : @SExpr (natParams univs)}
+    {es : List (@SExpr (natParams univs))}
+    (view : NatSpineConsView (Gamma := Gamma) univs D B e es R) :
+    NatTypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (natParams univs) B e)
+      (@SExpr.inst (natParams univs) view.codomain e) :=
+  natTypesInst univs view.codomainEq (view.argumentExpected univs)
+
+/-- Add one capture to a concrete path-indexed spine.  Type uniqueness
+aligns the exposed generated domain with the caller-selected shared capture
+type, and `PathSpineWF.cons` retains that local domain conversion. -/
+theorem natPathSpineCons (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {D B e R : @SExpr (natParams univs)}
+    {es : List (@SExpr (natParams univs))}
+    {alpha : Type}
+    {value type : alpha → @SExpr (natParams univs)}
+    {path : alpha} {paths : List alpha}
+    (hGamma : NatContextValid univs Gamma)
+    (view : NatSpineConsView (Gamma := Gamma) univs D B e es R)
+    (he : e = value path)
+    (htyped : @IsDefEq (natParams univs) Gamma
+      (value path) (value path) (type path))
+    (htail : @PathSpineWF (natParams univs) Gamma alpha value type
+      (@SExpr.inst (natParams univs) B e) paths R) :
+    @PathSpineWF (natParams univs) Gamma alpha value type
+      (@SExpr.forallE (natParams univs) D B) (path :: paths) R := by
+  letI : Params := natParams univs
+  subst e
+  obtain ⟨_, hdom⟩ := view.domainEq
+  obtain ⟨_, hshared⟩ :=
+    natTypeUniq univs hGamma view.argument htyped
+  obtain ⟨_, hconcrete⟩ :=
+    natTypesTrans univs hGamma ⟨_, hdom⟩ ⟨_, hshared⟩
+  exact .cons hconcrete.symm htail
+
+/-- Recover the path-indexed form of an already typed concrete spine.  The
+ordinary spine fixes each generated domain; concrete type uniqueness then
+aligns that domain with the independently selected shared capture type.
+Head and result conversions are retained verbatim. -/
+theorem natPathSpineOfSpineWF (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    {alpha : Type}
+    {value type : alpha → @SExpr (natParams univs)}
+    {A B : @SExpr (natParams univs)} {paths : List alpha}
+    (hGamma : NatContextValid univs Gamma)
+    (htyped : ∀ path, @IsDefEq (natParams univs) Gamma
+      (value path) (value path) (type path))
+    (H : @SpineWF (natParams univs) Gamma A (paths.map value) B) :
+    @PathSpineWF (natParams univs) Gamma alpha value type A paths B := by
+  letI : Params := natParams univs
+  generalize hargs : paths.map value = args at H
+  induction H generalizing paths with
+  | nil =>
+    have hpaths : paths = [] := by simpa using hargs
+    subst paths
+    exact .nil
+  | @cons e domain es result codomain harg htail ih =>
+    cases paths with
+    | nil => simp at hargs
+    | cons path paths =>
+      simp only [List.map_cons, List.cons.injEq] at hargs
+      obtain ⟨hvalue, hrest⟩ := hargs
+      subst e
+      obtain ⟨_, hdomain⟩ :=
+        natTypeUniq univs hGamma (htyped path) harg
+      exact .cons hdomain (ih hrest)
+  | @conv Head Head' u es result hHead htail ih =>
+    exact .conv hHead (ih hargs)
+  | @ret Head es result result' u htail hresult ih =>
+    exact .ret (ih hargs) hresult
+
+/-- The zero-rule match exposes exactly the three recursor captures. -/
+theorem natZeroCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (natParams univs))}
+    {recArgs ctorArgs : List (@SExpr (natParams univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0).Path →
+      @SExpr (natParams univs)}
+    (H : @Pattern.MatchesS (natParams univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0)
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ``Nat.zero ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs = [] ∧
+      (natCapturePaths NatGeneration.flatCtors[0]).map mcap =
+        recArgs.reverse := by
+  letI : Params := natParams univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, -⟩ := matchesS_varN_foldr hctor
+    have hctorArgs : ctorArgs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorArgs
+    refine ⟨hrecLen, rfl, ?_⟩
+    rw [natZeroCapturePaths]
+    change
+      ((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl).map
+          (Sum.elim recCap ctorCap) = recArgs.reverse
+    simpa [List.map_map, Function.comp_def] using hrecValues
+
+/-- The successor-rule match exposes the three recursor captures followed
+by its one constructor field. -/
+theorem natSuccCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (natParams univs))}
+    {recArgs ctorArgs : List (@SExpr (natParams univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1).Path →
+      @SExpr (natParams univs)}
+    (H : @Pattern.MatchesS (natParams univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1)
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ``Nat.succ ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs.length = 1 ∧
+      (natCapturePaths NatGeneration.flatCtors[1]).map mcap =
+        recArgs.reverse ++ ctorArgs.reverse := by
+  letI : Params := natParams univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, hctorValues⟩ := matchesS_varN_foldr hctor
+    refine ⟨hrecLen, hctorLen, ?_⟩
+    rw [natSuccCapturePaths]
+    change
+      (((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl ++
+          (Pattern.varNPaths (.const ``Nat.succ) 1).map Sum.inr).map
+        (Sum.elim recCap ctorCap)) = recArgs.reverse ++ ctorArgs.reverse
+    simpa [List.map_append, List.map_map, Function.comp_def,
+      hrecValues, hctorValues]
+
+theorem natPat_no_const (univs : Nat) {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : (natParams univs).Pat (.const c) r) : False := by
+  change NatPat (.const c) r at H
+  rcases natPat_pattern H with h | h <;> cases h
+
+theorem natType_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (natParams univs) ``Nat) : False := by
+  letI : Params := natParams univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  rcases natClassify_ctor_cases cl.cl.2.1 hshape with h | h
+  · simp at h
+  · simp at h
+
+/-- The instance-scoped proposition asserting strong self-typing of the Nat
+family head.  Packaging the proposition behind a `letI` keeps the ambient
+universe valuation explicit without leaking an unresolved `Params` argument
+through `SExpr` and `SLevel` in the theorem signature. -/
+def NatTypeStrong (univs : Nat) (Gamma : List (@SExpr (natParams univs))) : Prop :=
+  letI : Params := natParams univs
+  IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+    (SExpr.mkInst [] InductiveFixtures.natType.type)
+
+/-- Strong self-typing of the inductive family head, shared by both Nat
+constructor bundles. -/
+theorem natTypeStrong (univs : Nat)
+    (Gamma : List (@SExpr (natParams univs))) : NatTypeStrong univs Gamma := by
+  letI : Params := natParams univs
+  change IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+    (SExpr.mkInst [] InductiveFixtures.natType.type)
+  refine IsDefEqStrong.const
+    (ci := InductiveFixtures.natType.toVConstant) (ls := [])
+    (u := SLevel.succ (SLevel.succ SLevel.zero))
+    InductiveReplayFixtures.nat_type_env_lookup rfl ?_ ?_ ?_ ?_
+  · change IsDefEqStrong Gamma
+      (.sort (SLevel.succ SLevel.zero))
+      (.sort (SLevel.succ SLevel.zero))
+      (.sort (SLevel.succ (SLevel.succ SLevel.zero)))
+    exact .sort
+  · intro cl
+    exact (natType_not_ctor univs cl).elim
+  · intro cl
+    exact (natType_not_ctor univs cl).elim
+  · intro r hpat
+    exact (natPat_no_const univs hpat).elim
+
+/-- The result type of the constructor half of the semantic bridge, with the
+`Params` instance scoped inside the definition for stable elaboration. -/
+def NatCtorResult (univs : Nat) {c : Name} {ci : VConstant}
+    (ls : List (@SLevel (natParams univs)))
+    (Gamma : List (@SExpr (natParams univs)))
+    (cl : @CtorBundle.IsCtor (natParams univs) c) : Type :=
+  letI : Params := natParams univs
+  {F : CtorBundle c cl //
+    IsDefEqStrong Gamma (SExpr.mkInst ls ci.type) (F.rhs ls) (.sort F.u)}
+
+/-- The Nat classifier exposes exactly the zero and successor constructor
+bundles.  This proposition-valued existence theorem is the safe elimination
+boundary for the classifier proof. -/
+theorem natCtor_nonempty (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (natParams univs))}
+    {Gamma : List (@SExpr (natParams univs))}
+    (hci : natFinalEnv.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (natParams univs) c) :
+    Nonempty (NatCtorResult (ci := ci) univs ls Gamma cl) := by
+  letI : Params := natParams univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hcases := natClassify_ctor_cases cl.cl.2.1 hshape
+  unfold NatCtorResult
+  rcases hcases with hzero | hsucc
+  · obtain ⟨rfl, hcl⟩ := hzero
+    change some InductiveFixtures.natType.ctors[0].toVConstant = some ci at hci
+    have hci' : ci = InductiveFixtures.natType.ctors[0].toVConstant :=
+      Option.some.inj hci.symm
+    subst ci
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    let F : CtorBundle ``Nat.zero cl := {
+      I := ``Nat
+      Ts := []
+      args := []
+      u := SLevel.succ SLevel.zero
+      hlen := by simp [hcl, Classification.arity]
+      hclI := by
+        change natClassify ``Nat = some (.indTy 0)
+        simp [natClassify]
+      hu0 := by
+        intro h
+        have hv := congrArg (fun l : SLevel => l.1 []) h
+        simp [SLevel.succ, SLevel.zero] at hv }
+    refine ⟨⟨F, ?_⟩⟩
+    change IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type)
+    exact natTypeStrong univs Gamma
+  · obtain ⟨rfl, hcl⟩ := hsucc
+    change some InductiveFixtures.natType.ctors[1].toVConstant = some ci at hci
+    have hci' : ci = InductiveFixtures.natType.ctors[1].toVConstant :=
+      Option.some.inj hci.symm
+    subst ci
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    let one : SLevel := SLevel.succ SLevel.zero
+    let F : CtorBundle ``Nat.succ cl := {
+      I := ``Nat
+      Ts := [.const ``Nat []]
+      args := []
+      u := SLevel.imax one one
+      hlen := by simp [hcl, Classification.arity]
+      hclI := by
+        change natClassify ``Nat = some (.indTy 0)
+        simp [natClassify]
+      hu0 := by
+        intro h
+        have hv := congrArg (fun l : SLevel => l.1 []) h
+        simp [SLevel.imax, one, SLevel.succ, SLevel.zero,
+          Lean.Nat.imax] at hv }
+    refine ⟨⟨F, ?_⟩⟩
+    change IsDefEqStrong Gamma
+      (.forallE (.const ``Nat []) (.const ``Nat []))
+      (.forallE (.const ``Nat []) (.const ``Nat []))
+      (.sort (SLevel.imax one one))
+    exact IsDefEqStrong.forallEDF
+      (natTypeStrong univs Gamma)
+      (natTypeStrong univs (.const ``Nat [] :: Gamma))
+      (natTypeStrong univs (.const ``Nat [] :: Gamma))
+
+/-- The data-valued constructor bridge selected from `natCtor_nonempty`. -/
+noncomputable def natCtor (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (natParams univs))}
+    {Gamma : List (@SExpr (natParams univs))}
+    (hci : natFinalEnv.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (natParams univs) c) :
+    NatCtorResult (ci := ci) univs ls Gamma cl :=
+  Classical.choice (natCtor_nonempty univs hci hlen cl)
+
+/-! ### Concrete normal forms used by the Nat iota-site certificate -/
+
+def probeNatZeroRuleTypeV : VExpr :=
+  VExpr.forallE
+    (VExpr.forallE (VExpr.const ``Nat []) (VExpr.sort (VLevel.param 0)))
+    (VExpr.forallE
+      ((VExpr.bvar 0).app (VExpr.const ``Nat.zero []))
+      (VExpr.forallE
+        (VExpr.forallE (VExpr.const ``Nat [])
+          (VExpr.forallE
+            ((VExpr.bvar 2).app (VExpr.bvar 0))
+            ((VExpr.bvar 3).app
+              ((VExpr.const ``Nat.succ []).app (VExpr.bvar 1)))))
+        ((VExpr.bvar 2).app (VExpr.const ``Nat.zero []))))
+
+def probeNatRecTypeV : VExpr :=
+  VExpr.forallE
+    (VExpr.forallE (VExpr.const ``Nat []) (VExpr.sort (VLevel.param 0)))
+    (VExpr.forallE
+      ((VExpr.bvar 0).app (VExpr.const ``Nat.zero []))
+      (VExpr.forallE
+        (VExpr.forallE (VExpr.const ``Nat [])
+          (VExpr.forallE
+            ((VExpr.bvar 2).app (VExpr.bvar 0))
+            ((VExpr.bvar 3).app
+              ((VExpr.const ``Nat.succ []).app (VExpr.bvar 1)))))
+        (VExpr.forallE (VExpr.const ``Nat [])
+          ((VExpr.bvar 3).app (VExpr.bvar 0)))))
+
+def probeNatRuleBindersV : List VExpr :=
+  [VExpr.forallE (VExpr.const ``Nat []) (VExpr.sort (VLevel.param 0)),
+   (VExpr.bvar 0).app (VExpr.const ``Nat.zero []),
+   VExpr.forallE (VExpr.const ``Nat [])
+     (VExpr.forallE
+       ((VExpr.bvar 2).app (VExpr.bvar 0))
+       ((VExpr.bvar 3).app
+         ((VExpr.const ``Nat.succ []).app (VExpr.bvar 1))))]
+
+def probeNatZeroRuleResultV : VExpr :=
+  (VExpr.bvar 2).app (VExpr.const ``Nat.zero [])
+
+def probeNatZeroRuleLhsBodyV : VExpr :=
+  ((((VExpr.const ``Nat.rec [VLevel.param 0]).app (VExpr.bvar 2)).app
+    (VExpr.bvar 1)).app (VExpr.bvar 0)).app (VExpr.const ``Nat.zero [])
+
+def probeNatZeroRuleLhsV : VExpr :=
+  VExpr.lamN probeNatRuleBindersV probeNatZeroRuleLhsBodyV
+
+def probeNatSuccRuleBindersV : List VExpr :=
+  probeNatRuleBindersV ++ [VExpr.const ``Nat []]
+
+def probeNatSuccRuleResultV : VExpr :=
+  (VExpr.bvar 3).app
+    ((VExpr.const ``Nat.succ []).app (VExpr.bvar 0))
+
+def probeNatSuccRuleTypeV : VExpr :=
+  VExpr.forallN probeNatSuccRuleBindersV probeNatSuccRuleResultV
+
+def probeNatSuccRuleLhsBodyV : VExpr :=
+  ((((VExpr.const ``Nat.rec [VLevel.param 0]).app (VExpr.bvar 3)).app
+    (VExpr.bvar 2)).app (VExpr.bvar 1)).app
+      ((VExpr.const ``Nat.succ []).app (VExpr.bvar 0))
+
+def probeNatSuccRuleLhsV : VExpr :=
+  VExpr.lamN probeNatSuccRuleBindersV probeNatSuccRuleLhsBodyV
+
+theorem probeNatZeroRuleTypeV_eq :
+    (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type =
+      probeNatZeroRuleTypeV := by
+  native_decide
+
+theorem probeNatRecTypeV_eq :
+    (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type =
+      probeNatRecTypeV := by
+  native_decide
+
+theorem probeNatZeroRuleLhsV_eq :
+    (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs =
+      probeNatZeroRuleLhsV := by
+  native_decide
+
+theorem probeNatSuccRuleTypeV_eq :
+    (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type =
+      probeNatSuccRuleTypeV := by
+  native_decide
+
+theorem probeNatSuccRuleLhsV_eq :
+    (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs =
+      probeNatSuccRuleLhsV := by
+  native_decide
+
+theorem probeNatSuccCtorTypeV_eq :
+    InductiveFixtures.natType.ctors[1].type =
+      VExpr.forallE (VExpr.const ``Nat []) (VExpr.const ``Nat []) := by
+  native_decide
+
+theorem probeNatRuleRhs_ne :
+    (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs ≠
+      (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs := by
+  native_decide
+
+theorem probeNatFlatCtorZero_lookup :
+    NatGeneration.flatCtors[0]? =
+      some NatGeneration.flatCtors[0] :=
+  List.getElem?_eq_getElem (by decide)
+
+theorem probeNatFlatCtorSucc_lookup :
+    NatGeneration.flatCtors[1]? =
+      some NatGeneration.flatCtors[1] :=
+  List.getElem?_eq_getElem (by decide)
+
+theorem probeNatGeneratedRuleZero_lookup :
+    NatGeneration.generatedRules[0]? =
+      some (NatGeneration.rule 0 NatGeneration.flatCtors[0]) := by
+  native_decide
+
+theorem probeNatGeneratedRuleSucc_lookup :
+    NatGeneration.generatedRules[1]? =
+      some (NatGeneration.rule 1 NatGeneration.flatCtors[1]) := by
+  native_decide
+
+theorem probeCancelThreeLifts [Params] (e a b c : SExpr) :
+    (((e.lift.lift.lift.subst (Subst.one a).lift.lift).subst
+      (Subst.one b).lift).subst (Subst.one c)) = e := by
+  rw [SExpr.subst_subst, SExpr.subst_subst]
+  rw [SExpr.lift_subst, SExpr.lift_subst, SExpr.lift_subst]
+  rw [show ((Subst.one a).lift.lift.comp
+      ((Subst.one b).lift.comp (Subst.one c))).tail.tail.tail = Subst.id by
+    funext i
+    simp [Subst.comp, Subst.tail, Subst.lift, Subst.one,
+      Subst.cons, Subst.id, SExpr.subst]]
+  exact SExpr.subst_id
+
+theorem probeCancelTwoLifts [Params] (e a b : SExpr) :
+    ((e.lift.lift.subst (Subst.one a).lift).subst (Subst.one b)) = e := by
+  rw [SExpr.subst_subst]
+  rw [SExpr.lift_subst, SExpr.lift_subst]
+  rw [show ((Subst.one a).lift.comp (Subst.one b)).tail.tail =
+      Subst.id by
+    funext i
+    simp [Subst.comp, Subst.tail, Subst.lift, Subst.one,
+      Subst.cons, Subst.id, SExpr.subst]]
+  exact SExpr.subst_id
+
+theorem probeVCancelTwoLifts (e a b : VExpr) :
+    ((e.lift.lift.inst a 1).inst b) = e := by
+  rw [← VExpr.lift_instN_lo]
+  rw [VExpr.inst_lift, VExpr.inst_lift]
+
+theorem probeVCancelThreeLifts (e a b c : VExpr) :
+    ((((e.lift.lift.lift).inst a 2).inst b 1).inst c) = e := by
+  rw [← VExpr.lift_instN_lo]
+  rw [← VExpr.lift_instN_lo]
+  rw [probeVCancelTwoLifts, VExpr.inst_lift]
+
+theorem probeInstVParamZero [Params] (level : SLevel) :
+    SLevel.instV [level] (VLevel.param 0) = level := by
+  apply Subtype.ext
+  rfl
+
+theorem probeReifyInstVParamZero [Params] (level : SLevel) :
+    VLevel.inst [level.reify] (VLevel.param 0) = level.reify := by
+  rfl
+
+theorem probeReifySubstOne [Params] (a : SExpr) :
+    (fun i => (Subst.one a i).reify) = VExpr.Subst.one a.reify := by
+  funext i
+  cases i <;> rfl
+
+theorem probeReifySubstLift [Params] (sigma : Subst) :
+    (fun i => (sigma.lift i).reify) =
+      VExpr.Subst.lift (fun i => (sigma i).reify) := by
+  funext i
+  cases i with
+  | zero => rfl
+  | succ i =>
+    simpa only [Subst.lift, VExpr.Subst.lift, VExpr.lift_eq_lift'] using
+      SExpr.reify_lift' (sigma i)
+
+def probeSubstLiftN [Params] (sigma : Subst) : Nat → Subst
+  | 0 => sigma
+  | n + 1 => (probeSubstLiftN sigma n).lift
+
+theorem probeCancelInsertedBinder [Params] (e a : SExpr) : ∀ k,
+    (e.lift' (Lift.consN (.skip .refl) k)).subst
+      (probeSubstLiftN (Subst.one a) k) = e := by
+  induction e with
+  | bvar i =>
+    intro k
+    induction k generalizing i with
+    | zero =>
+      simp only [Lift.consN, probeSubstLiftN, SExpr.lift', Lift.liftVar,
+        SExpr.subst, Subst.one, Subst.cons]
+      rfl
+    | succ k ih =>
+      cases i with
+      | zero =>
+        simp [probeSubstLiftN, SExpr.subst, Subst.one, Subst.cons,
+          Subst.lift]
+      | succ i =>
+        simpa [probeSubstLiftN, Subst.lift, SExpr.subst, SExpr.lift] using
+          congrArg SExpr.lift (ih i)
+  | sort | const => intro k; rfl
+  | app f a ihf iha =>
+    intro k
+    simp [SExpr.subst, ihf k, iha k]
+  | lam A body ihA ihBody | forallE A body ihA ihBody =>
+    intro k
+    simp only [SExpr.lift', SExpr.subst]
+    rw [ihA k]
+    have hbody := ihBody (k + 1)
+    change (body.lift' (Lift.consN (.skip .refl) k).cons).subst
+      (probeSubstLiftN (Subst.one a) k).lift = body at hbody
+    rw [hbody]
+
+theorem probeCancelUnderOne [Params] (e a : SExpr) :
+    e.lift.lift.subst (Subst.one a).lift = e.lift := by
+  simpa [SExpr.lift, probeSubstLiftN, ← SExpr.lift'_comp] using
+    probeCancelInsertedBinder (e := e.lift) a 1
+
+theorem probeCancelUnderTwo [Params] (e a : SExpr) :
+    e.lift.lift.lift.subst (Subst.one a).lift.lift = e.lift.lift := by
+  simpa [SExpr.lift, probeSubstLiftN, ← SExpr.lift'_comp] using
+    probeCancelInsertedBinder (e := e.lift.lift) a 2
+
+theorem probeNatZeroRuleRecName :
+    NatGeneration.ruleRecName NatGeneration.flatCtors[0] = ``Nat.rec := by
+  native_decide
+
+theorem probeNatZeroCtorName :
+    NatGeneration.flatCtors[0].ctor.raw.name = ``Nat.zero := by
+  native_decide
+
+theorem probeNatSuccRuleRecName :
+    NatGeneration.ruleRecName NatGeneration.flatCtors[1] = ``Nat.rec := by
+  native_decide
+
+theorem probeNatSuccCtorName :
+    NatGeneration.flatCtors[1].ctor.raw.name = ``Nat.succ := by
+  native_decide
+
+def probeNatZeroRuleType (univs : Nat) (level : @SLevel (natParams univs)) :
+    @SExpr (natParams univs) :=
+  letI : Params := natParams univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))))
+
+theorem probeNatZeroRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (natParams univs)) :
+    @SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type =
+      probeNatZeroRuleType univs level := by
+  rw [probeNatZeroRuleTypeV_eq]
+  rfl
+
+def probeNatSuccRuleType (univs : Nat)
+    (level : @SLevel (natParams univs)) : @SExpr (natParams univs) :=
+  letI : Params := natParams univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        (SExpr.forallE (SExpr.const ``Nat [])
+          ((SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))))))
+
+theorem probeNatSuccRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (natParams univs)) :
+    @SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type =
+      probeNatSuccRuleType univs level := by
+  rw [probeNatSuccRuleTypeV_eq]
+  rfl
+
+/-- The descriptor half of `Params.Semantic.iotaRule`, recovered directly
+from the certified generated-rule membership proof.  The intermediate
+statement is proposition-valued so it can eliminate `IotaPat`; the public
+descriptor below selects the uniquely indexed witness. -/
+theorem natIotaRule_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (natParams univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    Nonempty (@Pattern.IotaRule (natParams univs)
+      rec major ctor arity r) := by
+  letI : Params := natParams univs
+  change NatPat (RecursorIotaPattern rec major ctor arity) r at H
+  obtain ⟨i, constructor, hentry, hpattern, -⟩ :=
+    VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration H
+  change RecursorIotaPattern rec major ctor arity =
+    RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor) at hpattern
+  obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure hentry,
+      NatGeneration.ruleCheck natRuleClosure (List.mem_of_getElem? hentry))
+  have Hgen : NatPat
+      (RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+        (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+        (NatGeneration.ruleArgArity constructor)) rgen :=
+    .mk hentry
+  have hr : r ≍ rgen :=
+    (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+      H Hgen .refl (Pattern.inter_self _)).2.2
+  have hr' : r = rgen := eq_of_heq hr
+  subst r
+  refine ⟨{
+    pat := ?_
+    df := NatGeneration.rule i constructor
+    registered := natRule_registered hentry
+    rhsClosed := natRuleClosure.rhs_closed hentry
+    capturePaths := natCapturePaths constructor
+    rhsTower := ?_ }⟩
+  · change NatPat _ _
+    exact Hgen
+  · simpa only [rgen,
+      VInductDecl.BlockGenerationChecked.rulePattern,
+      SimplePattern.toPattern, RecursorIotaPattern] using
+      natRuleRHS_tower hentry
+
+noncomputable def natIotaRule (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (natParams univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    @Pattern.IotaRule (natParams univs) rec major ctor arity r :=
+  Classical.choice (natIotaRule_nonempty univs H)
+
+/-- Every concrete Nat pattern match selects its canonical registered rule
+and carries a checked, conversion-aware capture spine and beta collapse. -/
+theorem natIotaSite_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (natParams univs))}
+    {A majorTerm : @SExpr (natParams univs)}
+    {recLs ctorLs : List (@SLevel (natParams univs))}
+    {recArgs ctorArgs : List (@SExpr (natParams univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (natParams univs)}
+    (rule : @Pattern.IotaRule (natParams univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (natParams univs))
+    (captureTyping : @Pattern.CaptureTyping (natParams univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : NatContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (natParams univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (natParams univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (natParams univs) Gamma
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs)))
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (natParams univs) Gamma A A
+      (@SExpr.sort (natParams univs) u)) :
+    Nonempty (@Pattern.IotaReductionSite (natParams univs) Gamma rec major ctor
+      arity r rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping) := by
+  letI : Params := natParams univs
+  have hpat := rule.pat
+  change NatPat _ _ at hpat
+  obtain ⟨i, constructor, hentry, hpattern, -⟩ :=
+    VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration hpat
+  change RecursorIotaPattern rec major ctor arity =
+    RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor) at hpattern
+  obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure hentry,
+      NatGeneration.ruleCheck natRuleClosure (List.mem_of_getElem? hentry))
+  have Hgen : NatPat
+      (RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+        (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+        (NatGeneration.ruleArgArity constructor)) rgen := .mk hentry
+  have hr : r ≍ rgen :=
+    (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+      hpat Hgen .refl (Pattern.inter_self _)).2.2
+  have hr' : r = rgen := eq_of_heq hr
+  subst r
+  rcases rule with
+    ⟨rulePat, df, ruleRegistered, rhsClosed, capturePaths, rhsTower⟩
+  change NatGeneration.ruleRHS natRuleClosure hentry =
+    Pattern.RHS.appN (.fixed df.rhs rhsClosed)
+      (capturePaths.map fun path => .var path) at rhsTower
+  rw [natRuleRHS_tower hentry] at rhsTower
+  obtain ⟨hrhs, hpaths⟩ := rhsFixedAppN_inj rhsTower
+  subst capturePaths
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  have hreg := ruleRegistered
+  change natFinalEnv.defeqs df at hreg
+  rw [natFinalEnv_defeqs_iff] at hreg
+  obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hreg
+  have hj' : j = 0 ∨ j = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hj
+    have : NatGeneration.generatedRules.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl <;> rcases hj' with rfl | rfl
+  all_goals
+    first
+    | have hc := Option.some.inj
+        (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    | have hc := Option.some.inj
+        (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    first
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleZero_lookup.symm.trans hj)
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleSucc_lookup.symm.trans hj)
+    subst df
+  all_goals (try simp at hrhs ⊢)
+  case inl.inl =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatZeroRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.zero := by
+      rw [← hc]
+      exact probeNatZeroCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      InductiveReplayFixtures.nat_rec_env_lookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      (ci := InductiveFixtures.natType.ctors[0].toVConstant) (by rfl)
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgs, hcaptures⟩ :=
+      natZeroCaptureValues univs matched
+    rw [hctorArgs] at typing matched redexSelf ⊢
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const InductiveReplayFixtures.nat_rec_env_lookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := natTypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := natSpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := natSpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := natSpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := natSpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := natTypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero [])) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := natTypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := natTypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := natTypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app (SExpr.const ``Nat.zero [])) A (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelTwoLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (probeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc]
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope .nil))
+    have hplainExplicit : SpineWF Gamma (probeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        [motive, minorZero, minorSucc] A := by
+      rw [probeNatZeroRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        ((natCapturePaths NatGeneration.flatCtors[0]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := natPathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (natFinalEnv_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : natFinalEnv.HasType univs (Gamma.map SExpr.reify)
+        (probeNatZeroRuleLhsV.instL vls)
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls) := by
+      rw [← probeNatZeroRuleLhsV_eq]
+      exact hlhs.weak0 natFinalEnv_ordered
+    unfold probeNatZeroRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf natFinalEnv_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hcoreV : natFinalEnv.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN (probeNatRuleBindersV.map (VExpr.instL vls))
+          (probeNatZeroRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify]
+        (VExpr.instRev (probeNatZeroRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [natParams, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst,
+          VExpr.inst_eq, probeReifySubstOne] using
+          hzeroV
+      refine .cons ?_ .nil
+      simpa [natParams, vls, VExpr.instL, SExpr.reify,
+        SExpr.reify_subst,
+        SExpr.reify_inst, VExpr.inst_eq, VExpr.instN_eq,
+        VExpr.Subst.liftN,
+        probeReifySubstOne, probeReifySubstLift] using
+        hsuccV
+    have hspineV := hcoreV
+    have hspineBody := VEnv.SpineWF.retarget hspineV
+      (by simp [probeNatRuleBindersV])
+      bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN natFinalEnv_ordered
+      hTel hbody hspineBody (by simp [probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong natFinalEnv_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (natStructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (natParams univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatZeroRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          (VExpr.const ``Nat.zero [])) := by
+      simp [probeNatZeroRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelTwoLifts, VExpr.inst_lift]
+      simpa only [VExpr.liftN_zero] using
+        probeVCancelTwoLifts motive.reify minorZero.reify minorSucc.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify])) := by
+      rw [probeNatZeroRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatZeroRuleLhsV,
+        probeNatRuleBindersV, probeNatZeroRuleLhsBodyV,
+        VExpr.lamN, VExpr.appN,
+        probeVCancelTwoLifts, VExpr.inst_lift, SExpr.mk,
+        SExpr.mkInst] using
+        hcollapseS
+    obtain ⟨_, hcollapseType⟩ := natTypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatZeroRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+  case inl.inr =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs)).elim
+  case inr.inl =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs.symm)).elim
+  case inr.inr =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatSuccRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.succ := by
+      rw [← hc]
+      exact probeNatSuccCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      InductiveReplayFixtures.nat_rec_env_lookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      InductiveReplayFixtures.nat_succ_env_lookup
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgsLen, hcaptures⟩ :=
+      natSuccCaptureValues univs matched
+    obtain ⟨pred, rfl⟩ := List.length_eq_one_iff.mp hctorArgsLen
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const InductiveReplayFixtures.nat_rec_env_lookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := natTypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := natSpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := natSpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := natSpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := natSpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hctorCanonical : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (SExpr.mkInst [] InductiveFixtures.natType.ctors[1].type) :=
+      .const InductiveReplayFixtures.nat_succ_env_lookup rfl
+    rw [probeNatSuccCtorTypeV_eq] at hctorCanonical
+    have hctorCanonical' : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (.forallE (.const ``Nat []) (.const ``Nat [])) := by
+      simpa [SExpr.mkInst] using hctorCanonical
+    have hctorType := natTypeUniq univs hGamma
+      hctorCanonical' typing.ctorHead
+    let predView := natSpineConsView univs hGamma hctorType typing.ctorSpine
+    have hpred := predView.argumentExpected univs
+    have hpred' : IsDefEq Gamma pred pred (.const ``Nat []) := by
+      simpa using hpred
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := natTypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred)) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := natTypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := natTypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := natTypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app ((SExpr.const ``Nat.succ []).app pred)) A
+        (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelThreeLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (probeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred]
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope (.cons hpred' .nil)))
+    have hplainExplicit : SpineWF Gamma (probeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        [motive, minorZero, minorSucc, pred] A := by
+      rw [probeNatSuccRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        ((natCapturePaths NatGeneration.flatCtors[1]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := natPathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (natFinalEnv_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : natFinalEnv.HasType univs (Gamma.map SExpr.reify)
+        (probeNatSuccRuleLhsV.instL vls)
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls) := by
+      rw [← probeNatSuccRuleLhsV_eq]
+      exact hlhs.weak0 natFinalEnv_ordered
+    unfold probeNatSuccRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf natFinalEnv_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hpredV := hpred'.reify hGamma
+    change natFinalEnv.IsDefEq univs (Gamma.map SExpr.reify)
+      pred.reify pred.reify _ at hpredV
+    have hcoreV : natFinalEnv.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN
+          (probeNatSuccRuleBindersV.map (VExpr.instL vls))
+          (probeNatSuccRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]
+        (VExpr.instRev (probeNatSuccRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [natParams, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, VExpr.inst_eq, probeReifySubstOne] using hzeroV
+      refine .cons ?_ ?_
+      · simpa [natParams, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, SExpr.reify_inst, VExpr.inst_eq,
+          VExpr.instN_eq, VExpr.Subst.liftN, probeReifySubstOne,
+          probeReifySubstLift] using hsuccV
+      refine .cons ?_ .nil
+      simpa [natParams, vls, VExpr.instL, VExpr.inst, SExpr.reify] using hpredV
+    have hspineBody := VEnv.SpineWF.retarget hcoreV
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV]) bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN natFinalEnv_ordered
+      hTel hbody hspineBody
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong natFinalEnv_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (natStructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (natParams univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatSuccRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          ((VExpr.const ``Nat.succ []).app pred.reify)) := by
+      simp [probeNatSuccRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift]
+      constructor
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelThreeLifts motive.reify minorZero.reify
+            minorSucc.reify pred.reify
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelTwoLifts minorZero.reify minorSucc.reify pred.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify])) := by
+      rw [probeNatSuccRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatSuccRuleLhsV,
+        probeNatSuccRuleBindersV, probeNatRuleBindersV,
+        probeNatSuccRuleLhsBodyV, VExpr.lamN, VExpr.appN,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift,
+        SExpr.mk, SExpr.mkInst] using hcollapseS
+    obtain ⟨_, hcollapseType⟩ := natTypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatSuccRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+
+/-- Data-valued Nat iota-site bridge selected from the proposition-valued
+certificate above. -/
+noncomputable def natIotaSite (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (natParams univs))}
+    {A majorTerm : @SExpr (natParams univs)}
+    {recLs ctorLs : List (@SLevel (natParams univs))}
+    {recArgs ctorArgs : List (@SExpr (natParams univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (natParams univs)}
+    (rule : @Pattern.IotaRule (natParams univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (natParams univs))
+    (captureTyping : @Pattern.CaptureTyping (natParams univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : NatContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (natParams univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (natParams univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (natParams univs) Gamma
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs)))
+      (@SExpr.app (natParams univs)
+        (recArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (natParams univs) f a)
+          (@SExpr.const (natParams univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (natParams univs) Gamma A A
+      (@SExpr.sort (natParams univs) u)) :
+    @Pattern.IotaReductionSite (natParams univs) Gamma rec major ctor arity r
+      rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping :=
+  Classical.choice (natIotaSite_nonempty univs rule captureType captureTyping
+    hGamma typing matched redexSelf AType)
+
+theorem natOnTelWeakR {env : VEnv} {univs : Nat}
+    (henv : env.Ordered) :
+    ∀ {Base As : List VExpr}, CtxClosed Base →
+      env.OnTel univs Base As → ∀ Tail,
+        env.OnTel univs (Base ++ Tail) As
+  | _, [], _, _, _ => trivial
+  | Base, A :: As, hBase, ⟨⟨u, hA⟩, hAs⟩, Tail => by
+      refine ⟨⟨u, VEnv.IsDefEq.weakR henv hBase hA Tail⟩, ?_⟩
+      have hAClosed : A.ClosedN Base.length := hA.closedN henv hBase
+      have hBase' : CtxClosed (A :: Base) := ⟨hBase, hAClosed⟩
+      simpa [List.append_assoc] using
+        natOnTelWeakR henv hBase' hAs Tail
+
+theorem natSelfSpine {env : VEnv} {univs : Nat} :
+    ∀ (As : List VExpr) (B : VExpr) (Gamma : List VExpr),
+      env.SpineWF univs (As.reverse ++ Gamma)
+        ((VExpr.forallN As B).liftN As.length)
+        (VExpr.bvarRevRange 0 As.length) B
+  | [], B, Gamma => by
+      simpa [VExpr.forallN, VExpr.bvarRevRange] using
+        (VEnv.SpineWF.nil : env.SpineWF univs Gamma B [] B)
+  | A :: As, B, Gamma => by
+      have harg : env.HasType univs
+          ((A :: As).reverse ++ Gamma)
+          (.bvar As.length) (A.liftN (As.length + 1)) := by
+        exact .bvar (by
+          have hlookup := Lean4Lean.Lookup.append
+            (A := A) As.reverse (Γ := Gamma)
+          simpa [List.append_assoc] using hlookup)
+      have htail := natSelfSpine (env := env) (univs := univs)
+        As B (A :: Gamma)
+      have htail' : env.SpineWF univs ((A :: As).reverse ++ Gamma)
+          ((VExpr.forallN As B).liftN (As.length + 1) 1 |>.inst
+            (.bvar As.length))
+          (VExpr.bvarRevRange 0 As.length) B := by
+        rw [VExpr.liftN_succ_inst_bvar]
+        simpa [List.append_assoc] using htail
+      have hout := VEnv.SpineWF.cons harg htail'
+      simpa [VExpr.forallN, VExpr.bvarRevRange, VExpr.liftN,
+        List.append_assoc] using hout
+
+theorem natReifyLevelWFContext [Params] (Gamma : List SExpr) :
+    OnCtx (Gamma.map SExpr.reify) (fun _ A => A.LevelWF Params.univs) := by
+  induction Gamma with
+  | nil => trivial
+  | cons A Gamma ih => exact ⟨ih, SExpr.reify_levelWF A⟩
+
+/-- Weakening specialized to the Nat fixture.  Unlike the generic theorem,
+this needs only the already-built constructor half of the prospective
+semantic instance; constant patterns are impossible in `NatPat`. -/
+theorem natStrongWeak (univs : Nat)
+    {rho : Lift} {Gamma Gamma' : List (@SExpr (natParams univs))}
+    {e1 e2 A : @SExpr (natParams univs)}
+    (W : @Ctx.Lift' (natParams univs) rho Gamma Gamma')
+    (H : @IsDefEqStrong (natParams univs) Gamma e1 e2 A) :
+    @IsDefEqStrong (natParams univs) Gamma'
+      (@SExpr.lift' (natParams univs) e1 rho)
+      (@SExpr.lift' (natParams univs) e2 rho)
+      (@SExpr.lift' (natParams univs) A rho) := by
+  letI : Params := natParams univs
+  induction H generalizing rho Gamma' with
+  | bvar h _ ihA => exact .bvar (h.weak' W) (ihA W)
+  | symm _ ih => exact (ih W).symm
+  | trans _ _ ih1 ih2 => exact (ih1 W).trans (ih2 W)
+  | sort => exact .sort
+  | @const c ci Gamma ls u hreg hlen hTy F hF hDef ihTy ihF ihDef =>
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero]
+    have hTy' := ihTy W
+    rw [((Params.henv.closedC hreg).mkInstS).lift'_eq .zero] at hTy'
+    let F' : ∀ cl, CtorBundle c cl := fun cl =>
+      (natCtor univs (Gamma := Gamma') hreg hlen cl).1
+    have hF' : ∀ cl, IsDefEqStrong Gamma'
+        (SExpr.mkInst ls ci.type) ((F' cl).rhs ls) (.sort (F' cl).u) := by
+      intro cl
+      exact (natCtor univs (Gamma := Gamma') hreg hlen cl).2
+    have hDef' : ∀ {r : (Pattern.const c).RHS × (Pattern.const c).Check},
+        Params.Pat (.const c) r →
+        IsDefEqStrong Gamma' (r.1.applyS ls Empty.elim) (.const c ls)
+          (SExpr.mkInst ls ci.type) := by
+      intro r hpat
+      exact (natPat_no_const univs hpat).elim
+    exact .const hreg hlen hTy' F' hF' hDef'
+  | appDF _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    have hResult := ihResult W
+    rw [SExpr.lift'_inst_hi, SExpr.lift'_inst_hi] at hResult
+    exact SExpr.lift'_inst_hi .. ▸
+      .appDF (ihA W) (ihCod W.cons) (ihf W) (iha W) hResult
+  | lamDF _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    exact .lamDF (ihA W) (ihB W.cons) (ihB' W.cons)
+      (ihBody W.cons) (ihBody' W.cons)
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    exact .forallEDF (ihA W) (ihBody W.cons) (ihBody' W.cons)
+  | defeqDF _ _ ihA ihe => exact .defeqDF (ihA W) (ihe W)
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    have hApp := ihApp W
+    have hInst := ihInst W
+    simp only [SExpr.lift'_inst_hi] at hApp hInst
+    rw [SExpr.lift'_inst_hi, SExpr.lift'_inst_hi]
+    exact .beta (ihBody W.cons) (ihArg W) hApp hInst
+  | @eta Gamma e A B hTerm hLam ihTerm ihLam =>
+    have hLam' : IsDefEqStrong Gamma'
+        (.lam (A.lift' rho) ((e.lift' rho).lift.app (.bvar 0)))
+        (.lam (A.lift' rho) ((e.lift' rho).lift.app (.bvar 0)))
+        (.forallE (A.lift' rho) (B.lift' rho.cons)) := by
+      simpa [SExpr.lift, ← SExpr.lift'_comp] using ihLam W
+    simpa [SExpr.lift, ← SExpr.lift'_comp] using
+      IsDefEqStrong.eta (ihTerm W) hLam'
+  | proofIrrel _ _ _ ihProp ihLeft ihRight =>
+    exact .proofIrrel (ihProp W) (ihLeft W) (ihRight W)
+  | @defn c ci Gamma ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    exact (natPat_no_const univs action.pat).elim
+  | extra action _ _ ihLeft ihRight =>
+    have hRight := ihRight W
+    rw [Pattern.RHS.lift'_applyS] at hRight
+    simpa only [Pattern.RHS.lift'_applyS] using
+      IsDefEqStrong.extra (action.weak' W) (ihLeft W) hRight
+
+theorem natZeroStrong (univs : Nat)
+    (Gamma : List (@SExpr (natParams univs))) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.const (natParams univs) ``Nat.zero [])
+      (@SExpr.const (natParams univs) ``Nat.zero [])
+      (@SExpr.const (natParams univs) ``Nat []) := by
+  letI : Params := natParams univs
+  let F : ∀ cl : CtorBundle.IsCtor ``Nat.zero,
+      CtorBundle ``Nat.zero cl := fun cl =>
+    (natCtor univs (Gamma := Gamma) (ls := []) (by rfl) rfl cl).1
+  refine .const (ci := InductiveFixtures.natType.ctors[0].toVConstant)
+    (u := SLevel.succ SLevel.zero) (by rfl) rfl
+    (natTypeStrong univs Gamma) F ?_ ?_
+  · intro cl
+    exact (natCtor univs (Gamma := Gamma) (ls := []) (by rfl) rfl cl).2
+  · intro r hpat
+    exact (natPat_no_const univs hpat).elim
+
+theorem natSuccStrong (univs : Nat)
+    (Gamma : List (@SExpr (natParams univs))) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.const (natParams univs) ``Nat.succ [])
+      (@SExpr.const (natParams univs) ``Nat.succ [])
+      (@SExpr.forallE (natParams univs)
+        (@SExpr.const (natParams univs) ``Nat [])
+        (@SExpr.const (natParams univs) ``Nat [])) := by
+  letI : Params := natParams univs
+  let one := SLevel.succ SLevel.zero
+  let F : ∀ cl : CtorBundle.IsCtor ``Nat.succ,
+      CtorBundle ``Nat.succ cl := fun cl =>
+    (natCtor univs (Gamma := Gamma) (ls := [])
+      InductiveReplayFixtures.nat_succ_env_lookup rfl cl).1
+  refine .const (ci := InductiveFixtures.natType.ctors[1].toVConstant)
+    (u := SLevel.imax one one)
+    InductiveReplayFixtures.nat_succ_env_lookup rfl ?_ F ?_ ?_
+  · rw [probeNatSuccCtorTypeV_eq]
+    change IsDefEqStrong Gamma
+      (.forallE (.const ``Nat []) (.const ``Nat []))
+      (.forallE (.const ``Nat []) (.const ``Nat []))
+      (.sort (SLevel.imax one one))
+    exact .forallEDF (natTypeStrong univs Gamma)
+      (natTypeStrong univs (.const ``Nat [] :: Gamma))
+      (natTypeStrong univs (.const ``Nat [] :: Gamma))
+  · intro cl
+    exact (natCtor univs (Gamma := Gamma) (ls := [])
+      InductiveReplayFixtures.nat_succ_env_lookup rfl cl).2
+  · intro r hpat
+    exact (natPat_no_const univs hpat).elim
+
+theorem natRec_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (natParams univs) ``Nat.rec) : False := by
+  letI : Params := natParams univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  rcases natClassify_ctor_cases cl.cl.2.1 hshape with h | h
+  · simp at h
+  · simp at h
+
+theorem probeNatTypeTypeV_eq :
+    InductiveFixtures.natType.type =
+      VExpr.sort (VLevel.succ VLevel.zero) := by
+  native_decide
+
+/-- The zero-rule telescope contains exactly the validity data needed to
+type the recursor's one additional major-argument binder. -/
+theorem natRecStrongOfZeroRuleType (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (@SExpr.sort (natParams univs) u)) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.const (natParams univs) ``Nat.rec [level])
+      (@SExpr.const (natParams univs) ``Nat.rec [level])
+      (@SExpr.mkInst (natParams univs) [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr := (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let ZeroResult : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc ZeroResult)))
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc ZeroResult)))
+      (.sort ruleSort) := by
+    simpa [probeNatZeroRuleType, Motive, MinorZero, MinorSucc, ZeroResult,
+      NatS] using hRuleType
+  clear hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, resultSort, hZeroResultType⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+  have hMotiveDeep : IsDefEqStrong (NatS :: Delta)
+      (.bvar 3) (.bvar 3) (.forallE NatS (.sort level)) := by
+    let rho : Lift := .skip (.skip (.skip (.skip .refl)))
+    have W4 : Ctx.Lift' rho Gamma (NatS :: Delta) := by
+      exact .skip (.skip (.skip (.skip .refl)))
+    have hMotiveLifted := natStrongWeak univs W4 hMotiveType
+    have hLookup : Lookup (NatS :: Delta) 3
+        (Motive.lift.lift.lift.lift) := .succ (.succ (.succ .zero))
+    have hBvar : IsDefEqStrong (NatS :: Delta) (.bvar 3) (.bvar 3)
+        (Motive.lift.lift.lift.lift) := .bvar hLookup hMotiveLifted
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hMajor : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: Delta)
+    change IsDefEqStrong (NatS :: Delta) (.const ``Nat []) (.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hMotiveMajor : IsDefEqStrong (NatS :: Delta)
+      ((SExpr.bvar 3).app (SExpr.bvar 0))
+      ((SExpr.bvar 3).app (SExpr.bvar 0)) (SExpr.sort level) := by
+    exact .appDF
+      (natTypeStrong univs (NatS :: Delta))
+      (by exact IsDefEqStrong.sort)
+      hMotiveDeep hMajor (by exact IsDefEqStrong.sort)
+  have hMajorTail := IsDefEqStrong.forallEDF
+    (natTypeStrong univs Delta) hMotiveMajor hMotiveMajor
+  have hAfterSucc := IsDefEqStrong.forallEDF
+    hMinorSuccType hMajorTail hMajorTail
+  have hAfterZero := IsDefEqStrong.forallEDF
+    hMinorZeroType hAfterSucc hAfterSucc
+  have hRecType := IsDefEqStrong.forallEDF
+    hMotiveType hAfterZero hAfterZero
+  have hRecType' : ∃ u, IsDefEqStrong Gamma
+      (SExpr.mkInst [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type)
+      (SExpr.mkInst [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type)
+      (.sort u) := by
+    refine ⟨motiveSort.imax (zeroSort.imax
+      (succSort.imax ((SLevel.instV [] VLevel.zero.succ).imax level))), ?_⟩
+    rw [probeNatRecTypeV_eq]
+    simpa [probeNatRecTypeV, Motive, MinorZero, MinorSucc, NatS,
+      SExpr.mkInst, probeInstVParamZero] using hRecType
+  obtain ⟨recSort, hRecType'⟩ := hRecType'
+  let F : ∀ cl : CtorBundle.IsCtor ``Nat.rec,
+      CtorBundle ``Nat.rec cl := fun cl => (natRec_not_ctor univs cl).elim
+  refine .const InductiveReplayFixtures.nat_rec_env_lookup rfl hRecType' F ?_ ?_
+  · intro cl
+    exact (natRec_not_ctor univs cl).elim
+  · intro r hpat
+    exact (natPat_no_const univs hpat).elim
+
+theorem natZeroRuleBodyStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (@SExpr.sort (natParams univs) u)) :
+    letI : Params := natParams univs
+    let Motive : SExpr := SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE (SExpr.const ``Nat []) <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    IsDefEqStrong (MinorSucc :: MinorZero :: Motive :: Gamma)
+      (((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero []))
+      (((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero []))
+      ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let ZeroResult : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc ZeroResult)))
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc ZeroResult)))
+      (.sort ruleSort) := by
+    simpa [probeNatZeroRuleType, Motive, MinorZero, MinorSucc, ZeroResult,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, resultSort, hResultType⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  let rho3 : Lift := .skip (.skip (.skip .refl))
+  have W3 : Ctx.Lift' rho3 Gamma Delta := by
+    exact .skip (.skip (.skip .refl))
+  let rho2 : Lift := .skip (.skip .refl)
+  have W2 : Ctx.Lift' rho2 (Motive :: Gamma) Delta := by
+    exact .skip (.skip .refl)
+  let rho1 : Lift := .skip .refl
+  have W1 : Ctx.Lift' rho1 (MinorZero :: Motive :: Gamma) Delta := by
+    exact .skip .refl
+  have hMotiveTypeD := natStrongWeak univs W3 hMotiveType
+  have hRest1D := natStrongWeak univs W2 hRest1
+  have hMinorZeroTypeD := natStrongWeak univs W2 hMinorZeroType
+  have hRest2D := natStrongWeak univs W1 hRest2
+  have hMinorSuccTypeD := natStrongWeak univs W1 hMinorSuccType
+  have hP : IsDefEqStrong Delta (SExpr.bvar 2) (SExpr.bvar 2) Motive := by
+    have hLookup : Lookup Delta 2 (Motive.lift.lift.lift) :=
+      .succ (.succ .zero)
+    have h := IsDefEqStrong.bvar hLookup hMotiveTypeD
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using h
+  have hMotiveTypeD' : IsDefEqStrong Delta Motive Motive
+      (SExpr.sort motiveSort) := by
+    simpa [rho3, Motive, NatS, SExpr.lift, SExpr.lift'] using hMotiveTypeD
+  let ZeroTy : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let SuccTy : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 3).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 4).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  have hZeroTypeD : IsDefEqStrong Delta ZeroTy ZeroTy
+      (SExpr.sort zeroSort) := by
+    simpa [rho2, ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using
+      hMinorZeroTypeD
+  have hSuccTypeD : IsDefEqStrong Delta SuccTy SuccTy
+      (SExpr.sort succSort) := by
+    simpa [rho1, SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+      hMinorSuccTypeD
+  have hZ : IsDefEqStrong Delta (SExpr.bvar 1) (SExpr.bvar 1) ZeroTy := by
+    have hLookup : Lookup Delta 1 (MinorZero.lift.lift) := .succ .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hZeroTypeD)
+    simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hBvar
+  have hS : IsDefEqStrong Delta (SExpr.bvar 0) (SExpr.bvar 0) SuccTy := by
+    have hLookup : Lookup Delta 0 MinorSucc.lift := .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+        hSuccTypeD)
+    simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hZero := natZeroStrong univs Delta
+  have hPZero : IsDefEqStrong Delta ZeroTy ZeroTy (SExpr.sort level) := by
+    simpa [ZeroTy, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      (IsDefEqStrong.appDF (natTypeStrong univs Delta) .sort hP hZero .sort)
+  have hMotiveDeep : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 3) (SExpr.bvar 3)
+      (SExpr.forallE NatS (SExpr.sort level)) := by
+    let rho4 : Lift := .skip (.skip (.skip (.skip .refl)))
+    have W4 : Ctx.Lift' rho4 Gamma (NatS :: Delta) := by
+      exact .skip (.skip (.skip (.skip .refl)))
+    have hMotiveLifted := natStrongWeak univs W4 hMotiveType
+    have hLookup : Lookup (NatS :: Delta) 3
+        (Motive.lift.lift.lift.lift) := .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup hMotiveLifted
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hMajor : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: Delta)
+    change IsDefEqStrong (NatS :: Delta) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hMotiveMajor : IsDefEqStrong (NatS :: Delta)
+      ((SExpr.bvar 3).app (SExpr.bvar 0))
+      ((SExpr.bvar 3).app (SExpr.bvar 0)) (SExpr.sort level) :=
+    .appDF (natTypeStrong univs (NatS :: Delta)) .sort
+      hMotiveDeep hMajor .sort
+  let MajorTail : SExpr :=
+    SExpr.forallE NatS ((SExpr.bvar 3).app (SExpr.bvar 0))
+  let natSort : SLevel := SLevel.instV [] VLevel.zero.succ
+  let majorTailSort : SLevel := natSort.imax level
+  have hMajorTail : IsDefEqStrong Delta MajorTail MajorTail
+      (SExpr.sort majorTailSort) := by
+    simpa [MajorTail, majorTailSort, natSort] using
+      IsDefEqStrong.forallEDF
+        (natTypeStrong univs Delta) hMotiveMajor hMotiveMajor
+  /- Build the generic recursor tail under fresh motive/minor binders. -/
+  let G1 : List SExpr := Motive :: Delta
+  let G2 : List SExpr := MinorZero :: G1
+  let G3 : List SExpr := MinorSucc :: G2
+  have hZeroTypeG : IsDefEqStrong G1 MinorZero MinorZero
+      (SExpr.sort zeroSort) := by
+    have h := natStrongWeak univs W3.cons hMinorZeroType
+    simpa [G1, rho3, Motive, MinorZero, NatS, SExpr.lift, SExpr.lift'] using h
+  have hSuccTypeG : IsDefEqStrong G2 MinorSucc MinorSucc
+      (SExpr.sort succSort) := by
+    have h := natStrongWeak univs W3.cons.cons hMinorSuccType
+    simpa [G2, G1, rho3, Motive, MinorZero, MinorSucc, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hMotiveGeneric : IsDefEqStrong (NatS :: G3)
+      (SExpr.bvar 3) (SExpr.bvar 3)
+      (SExpr.forallE NatS (SExpr.sort level)) := by
+    let rho4g : Lift := .skip (.skip (.skip (.skip .refl)))
+    have W4g : Ctx.Lift' rho4g Delta (NatS :: G3) := by
+      exact .skip (.skip (.skip (.skip .refl)))
+    have hLift := natStrongWeak univs W4g hMotiveTypeD'
+    have hLookup : Lookup (NatS :: G3) 3
+        (Motive.lift.lift.lift.lift) := .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup hLift
+    simpa [G3, G2, G1, Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hMajorGeneric : IsDefEqStrong (NatS :: G3)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: G3)
+    change IsDefEqStrong (NatS :: G3) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hGenericResult : IsDefEqStrong (NatS :: G3)
+      ((SExpr.bvar 3).app (SExpr.bvar 0))
+      ((SExpr.bvar 3).app (SExpr.bvar 0)) (SExpr.sort level) :=
+    .appDF (natTypeStrong univs (NatS :: G3)) .sort
+      hMotiveGeneric hMajorGeneric .sort
+  have hMajorTailG : IsDefEqStrong G3
+      (SExpr.forallE NatS ((SExpr.bvar 3).app (SExpr.bvar 0)))
+      (SExpr.forallE NatS ((SExpr.bvar 3).app (SExpr.bvar 0)))
+      (SExpr.sort majorTailSort) := by
+    simpa [majorTailSort, natSort] using
+      IsDefEqStrong.forallEDF
+        (natTypeStrong univs G3) hGenericResult hGenericResult
+  have hRecAfterSuccG := IsDefEqStrong.forallEDF
+    hSuccTypeG hMajorTailG hMajorTailG
+  have hRecAfterZeroG := IsDefEqStrong.forallEDF
+    hZeroTypeG hRecAfterSuccG hRecAfterSuccG
+  have hRecTypeD := IsDefEqStrong.forallEDF
+    hMotiveTypeD' hRecAfterZeroG hRecAfterZeroG
+  have hRecTypeInst : ∃ u, IsDefEqStrong Delta
+      (SExpr.mkInst [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type)
+      (SExpr.mkInst [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type)
+      (SExpr.sort u) := by
+    refine ⟨motiveSort.imax
+      (zeroSort.imax (succSort.imax majorTailSort)), ?_⟩
+    rw [probeNatRecTypeV_eq]
+    simpa [probeNatRecTypeV, G3, G2, G1, Motive, MinorZero, MinorSucc,
+      NatS, majorTailSort, natSort, SExpr.mkInst, probeInstVParamZero]
+      using hRecTypeD
+  obtain ⟨recSort, hRecTypeInst⟩ := hRecTypeInst
+  let F : ∀ cl : CtorBundle.IsCtor ``Nat.rec,
+      CtorBundle ``Nat.rec cl := fun cl => (natRec_not_ctor univs cl).elim
+  have hRec : IsDefEqStrong Delta
+      (SExpr.const ``Nat.rec [level]) (SExpr.const ``Nat.rec [level])
+      (SExpr.mkInst [level]
+        (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) := by
+    refine .const InductiveReplayFixtures.nat_rec_env_lookup rfl
+      hRecTypeInst F ?_ ?_
+    · intro cl
+      exact (natRec_not_ctor univs cl).elim
+    · intro r hpat
+      exact (natPat_no_const univs hpat).elim
+  /- Instantiate the generic recursor telescope with the three captures. -/
+  have hMajorTailS : IsDefEqStrong (SuccTy :: Delta)
+      MajorTail.lift MajorTail.lift (SExpr.sort majorTailSort) := by
+    simpa [MajorTail, SuccTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := SuccTy)) hMajorTail
+  have hAfterSucc : IsDefEqStrong Delta
+      (SExpr.forallE SuccTy MajorTail.lift)
+      (SExpr.forallE SuccTy MajorTail.lift)
+      (SExpr.sort (succSort.imax majorTailSort)) :=
+    .forallEDF hSuccTypeD hMajorTailS hMajorTailS
+  have hSuccTypeZ : IsDefEqStrong (ZeroTy :: Delta)
+      SuccTy.lift SuccTy.lift (SExpr.sort succSort) := by
+    simpa [SuccTy, ZeroTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := ZeroTy)) hSuccTypeD
+  let rhoZS : Lift := .skip (.skip .refl)
+  have WZS : Ctx.Lift' rhoZS Delta (SuccTy.lift :: ZeroTy :: Delta) := by
+    exact .skip (.skip .refl)
+  have hMajorTailZS : IsDefEqStrong (SuccTy.lift :: ZeroTy :: Delta)
+      MajorTail.lift.lift MajorTail.lift.lift
+      (SExpr.sort majorTailSort) := by
+    simpa [rhoZS, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs WZS hMajorTail
+  have hAfterSuccZ : IsDefEqStrong (ZeroTy :: Delta)
+      (SExpr.forallE SuccTy.lift MajorTail.lift.lift)
+      (SExpr.forallE SuccTy.lift MajorTail.lift.lift)
+      (SExpr.sort (succSort.imax majorTailSort)) :=
+    .forallEDF hSuccTypeZ hMajorTailZS hMajorTailZS
+  have hAfterZero : IsDefEqStrong Delta
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift))
+      (SExpr.sort (zeroSort.imax (succSort.imax majorTailSort))) :=
+    .forallEDF hZeroTypeD hAfterSuccZ hAfterSuccZ
+  have hRecP0 := IsDefEqStrong.appDF
+    hMotiveTypeD' hRecAfterZeroG hRec hP hAfterZero
+  have hRecP : IsDefEqStrong Delta
+      ((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2))
+      ((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift)) := by
+    simpa [G3, G2, G1, ZeroTy, SuccTy, MajorTail, Motive, MinorZero,
+      MinorSucc, NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id, probeCancelUnderOne, probeCancelUnderTwo]
+      using hRecP0
+  have hRecPZ0 := IsDefEqStrong.appDF
+    hZeroTypeD hAfterSuccZ hRecP hZ hAfterSucc
+  have hRecPZ : IsDefEqStrong Delta
+      (((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1))
+      (((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1))
+      (SExpr.forallE SuccTy MajorTail.lift) := by
+    simpa [ZeroTy, SuccTy, MajorTail, NatS, SExpr.lift, SExpr.lift',
+      SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRecPZ0
+  have hRecPZS0 := IsDefEqStrong.appDF
+    hSuccTypeD hMajorTailS hRecPZ hS hMajorTail
+  have hRecPZS : IsDefEqStrong Delta
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0))
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)) MajorTail := by
+    simpa [SuccTy, MajorTail, NatS, SExpr.lift, SExpr.lift',
+      SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRecPZS0
+  have hBody0 := IsDefEqStrong.appDF
+    (natTypeStrong univs Delta) hMotiveMajor hRecPZS hZero hPZero
+  have hBody : IsDefEqStrong Delta
+      (((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero []))
+      (((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero [])) ZeroTy := by
+    simpa [MajorTail, ZeroTy, SExpr.inst, SExpr.subst, Subst.one,
+      Subst.cons, Subst.lift, Subst.id] using hBody0
+  simpa [Delta, Motive, MinorZero, MinorSucc, ZeroResult, NatS,
+    SExpr.lift, SExpr.lift', probeCancelUnderOne, probeCancelUnderTwo]
+    using hBody
+
+theorem natZeroRuleAppliedStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hHead : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (probeNatZeroRuleType univs level)) :
+    letI : Params := natParams univs
+    let Motive : SExpr :=
+      SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE (SExpr.const ``Nat []) <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+        (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+    IsDefEqStrong Delta AppliedRhs AppliedRhs
+      ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+      (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc Result)))
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc Result)))
+      (.sort ruleSort) := by
+    simpa [probeNatZeroRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, resultSort, hResultType⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  let rho3 : Lift := .skip (.skip (.skip .refl))
+  have W3 : Ctx.Lift' rho3 Gamma Delta :=
+    .skip (.skip (.skip .refl))
+  let rho2 : Lift := .skip (.skip .refl)
+  have W2 : Ctx.Lift' rho2 (Motive :: Gamma) Delta :=
+    .skip (.skip .refl)
+  let rho1 : Lift := .skip .refl
+  have W1 : Ctx.Lift' rho1 (MinorZero :: Motive :: Gamma) Delta :=
+    .skip .refl
+  have hRuleTypeD0 := natStrongWeak univs W3 hRuleType'
+  have hRuleTypeD : IsDefEqStrong Delta
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc Result)))
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc Result)))
+      (.sort ruleSort) := by
+    simpa [rho3, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift'] using hRuleTypeD0
+  obtain ⟨⟨_, hMotiveTypeD⟩, _, hCod1⟩ :=
+    hRuleTypeD.forallE_inv' (.inl rfl)
+  have hRest1D0 := natStrongWeak univs W2 hRest1
+  have hRest1D : IsDefEqStrong Delta
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc Result)).lift' rho2)
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc Result)).lift' rho2)
+      (SExpr.sort restSort1) := hRest1D0
+  have hRest2D0 := natStrongWeak univs W1 hRest2
+  have hRest2D : IsDefEqStrong Delta
+      ((SExpr.forallE MinorSucc Result).lift' rho1)
+      ((SExpr.forallE MinorSucc Result).lift' rho1)
+      (SExpr.sort restSort2) := hRest2D0
+  have hResultD : IsDefEqStrong Delta Result Result
+      (.sort resultSort) := by
+    simpa [Result, rho1, SExpr.lift, SExpr.lift'] using hResultType
+  have hMotiveTypeD' : IsDefEqStrong Delta Motive Motive
+      (.sort motiveSort) := by
+    simpa [rho3, Motive, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W3 hMotiveType
+  let ZeroTy : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let SuccTy : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 3).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 4).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  have hZeroTypeD : IsDefEqStrong Delta ZeroTy ZeroTy
+      (.sort zeroSort) := by
+    simpa [rho2, ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W2 hMinorZeroType
+  have hSuccTypeD : IsDefEqStrong Delta SuccTy SuccTy
+      (.sort succSort) := by
+    simpa [rho1, SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W1 hMinorSuccType
+  have hP : IsDefEqStrong Delta (.bvar 2) (.bvar 2) Motive := by
+    have hLookup : Lookup Delta 2 (Motive.lift.lift.lift) :=
+      .succ (.succ .zero)
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using
+      IsDefEqStrong.bvar hLookup
+        (natStrongWeak univs W3 hMotiveType)
+  have hZ : IsDefEqStrong Delta (.bvar 1) (.bvar 1) ZeroTy := by
+    have hLookup : Lookup Delta 1 (MinorZero.lift.lift) := .succ .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hZeroTypeD)
+    simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hBvar
+  have hS : IsDefEqStrong Delta (.bvar 0) (.bvar 0) SuccTy := by
+    have hLookup : Lookup Delta 0 MinorSucc.lift := .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+        hSuccTypeD)
+    simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hHeadRaw : IsDefEqStrong Gamma
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type) := by
+    simpa only [probeNatZeroRuleTypeS_eq] using hHead
+  have hHeadD0 := natStrongWeak univs W3 hHeadRaw
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, typeClosed⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorZero_lookup)
+  rw [rhsClosed.mkInstS.lift'_eq .zero,
+    typeClosed.mkInstS.lift'_eq .zero] at hHeadD0
+  have hHeadD : IsDefEqStrong Delta
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (.forallE Motive (.forallE MinorZero (.forallE MinorSucc Result))) := by
+    simpa [probeNatZeroRuleTypeS_eq, probeNatZeroRuleType, Motive,
+      MinorZero, MinorSucc, Result, NatS] using hHeadD0
+  /- Rebuild the codomain tower once over generic binders and once over the
+  three actual captures.  Keeping both towers at the same computed universe
+  avoids relying on uniqueness of the sort witnesses returned by inversion. -/
+  let G1 : List SExpr := Motive :: Delta
+  let G2 : List SExpr := MinorZero :: G1
+  let G3 : List SExpr := MinorSucc :: G2
+  have hZeroTypeG : IsDefEqStrong G1 MinorZero MinorZero
+      (SExpr.sort zeroSort) := by
+    have h := natStrongWeak univs W3.cons hMinorZeroType
+    simpa [G1, rho3, Motive, MinorZero, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hSuccTypeG : IsDefEqStrong G2 MinorSucc MinorSucc
+      (SExpr.sort succSort) := by
+    have h := natStrongWeak univs W3.cons.cons hMinorSuccType
+    simpa [G2, G1, rho3, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hResultTypeG : IsDefEqStrong G3 Result Result
+      (SExpr.sort resultSort) := by
+    have h := natStrongWeak univs W3.cons.cons.cons hResultType
+    simpa [G3, G2, G1, rho3, Motive, MinorZero, MinorSucc, Result,
+      NatS, SExpr.lift, SExpr.lift'] using h
+  have hAfterSuccG : IsDefEqStrong G2
+      (SExpr.forallE MinorSucc Result)
+      (SExpr.forallE MinorSucc Result)
+      (SExpr.sort (succSort.imax resultSort)) :=
+    .forallEDF hSuccTypeG hResultTypeG hResultTypeG
+  have hAfterZeroG : IsDefEqStrong G1
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))
+      (SExpr.sort (zeroSort.imax (succSort.imax resultSort))) :=
+    .forallEDF hZeroTypeG hAfterSuccG hAfterSuccG
+  have hResultS : IsDefEqStrong (SuccTy :: Delta)
+      Result.lift Result.lift (SExpr.sort resultSort) := by
+    simpa [SExpr.lift] using
+      natStrongWeak univs (Ctx.Lift'.one (A := SuccTy)) hResultD
+  have hAfterSucc : IsDefEqStrong Delta
+      (SExpr.forallE SuccTy Result.lift)
+      (SExpr.forallE SuccTy Result.lift)
+      (SExpr.sort (succSort.imax resultSort)) :=
+    .forallEDF hSuccTypeD hResultS hResultS
+  have hSuccTypeZ : IsDefEqStrong (ZeroTy :: Delta)
+      SuccTy.lift SuccTy.lift (SExpr.sort succSort) := by
+    simpa [SuccTy, ZeroTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := ZeroTy)) hSuccTypeD
+  let rhoZS : Lift := .skip (.skip .refl)
+  have WZS : Ctx.Lift' rhoZS Delta
+      (SuccTy.lift :: ZeroTy :: Delta) :=
+    .skip (.skip .refl)
+  have hResultZS : IsDefEqStrong (SuccTy.lift :: ZeroTy :: Delta)
+      Result.lift.lift Result.lift.lift (SExpr.sort resultSort) := by
+    simpa [rhoZS, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs WZS hResultD
+  have hAfterSuccZ : IsDefEqStrong (ZeroTy :: Delta)
+      (SExpr.forallE SuccTy.lift Result.lift.lift)
+      (SExpr.forallE SuccTy.lift Result.lift.lift)
+      (SExpr.sort (succSort.imax resultSort)) :=
+    .forallEDF hSuccTypeZ hResultZS hResultZS
+  have hAfterZero : IsDefEqStrong Delta
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift Result.lift.lift))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift Result.lift.lift))
+      (SExpr.sort (zeroSort.imax (succSort.imax resultSort))) :=
+    .forallEDF hZeroTypeD hAfterSuccZ hAfterSuccZ
+  have hAppP0 := IsDefEqStrong.appDF
+    hMotiveTypeD' hAfterZeroG hHeadD hP hAfterZero
+  have hAppP : IsDefEqStrong Delta
+      ((SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs).app (.bvar 2))
+      ((SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs).app (.bvar 2))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift Result.lift.lift)) := by
+    simpa [G3, G2, G1, ZeroTy, SuccTy, Result, Motive, MinorZero,
+      MinorSucc, NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id, probeCancelUnderOne, probeCancelUnderTwo]
+      using hAppP0
+  have hAppZ0 := IsDefEqStrong.appDF
+    hZeroTypeD hAfterSuccZ hAppP hZ hAfterSucc
+  have hAppZ : IsDefEqStrong Delta
+      (((SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs).app
+          (.bvar 2)).app (.bvar 1))
+      (((SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs).app
+          (.bvar 2)).app (.bvar 1))
+      (SExpr.forallE SuccTy Result.lift) := by
+    simpa [ZeroTy, SuccTy, Result, NatS, SExpr.lift, SExpr.lift',
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hAppZ0
+  have hAppS0 := IsDefEqStrong.appDF
+    hSuccTypeD hResultS hAppZ hS hResultD
+  simpa [Delta, AppliedRhs, Result, SuccTy, MinorSucc, NatS,
+    SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+    Subst.one, Subst.cons, Subst.lift, Subst.id,
+    probeCancelUnderOne, probeCancelUnderTwo] using hAppS0
+
+theorem natZeroRuleActionSound (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs)) :
+    letI : Params := natParams univs
+    let Motive : SExpr :=
+      SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE (SExpr.const ``Nat []) <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+    let Redex : SExpr :=
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero [])
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+        (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+    let Result : SExpr :=
+      (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+    IsDefEq Delta Redex AppliedRhs Result := by
+  letI : Params := natParams univs
+  let Motive : SExpr :=
+    SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE (SExpr.const ``Nat []) <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Delta0 : List SExpr := [MinorSucc, MinorZero, Motive]
+  let Delta : List SExpr := Delta0 ++ Gamma
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+      (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+        (SExpr.const ``Nat.zero [])
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+      (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+  let Result : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let vls : List VLevel := [level.reify]
+  let argsV : List VExpr := [VExpr.bvar 2, VExpr.bvar 1, VExpr.bvar 0]
+  let AsV : List VExpr :=
+    probeNatRuleBindersV.map (VExpr.instL vls)
+  let ResultV : VExpr := probeNatZeroRuleResultV.instL vls
+  have hvls : ∀ l ∈ vls, l.WF univs := by
+    intro l hl
+    simp only [vls, List.mem_singleton] at hl
+    subst l
+    exact SLevel.reify_wf level
+  have hreg := natRule_registered probeNatFlatCtorZero_lookup
+  have hlhs0 := (natFinalEnv_ordered.defEqWF hreg).1.instL hvls
+  rw [probeNatZeroRuleLhsV_eq] at hlhs0
+  unfold probeNatZeroRuleLhsV at hlhs0
+  rw [VExpr.instL_lamN] at hlhs0
+  obtain ⟨hTel, bodyType, hbody⟩ :=
+    VEnv.HasType.lamN_wf natFinalEnv_ordered (by trivial) hlhs0
+  have hTel' : natFinalEnv.OnTel univs [] AsV := by
+    simpa [AsV] using hTel
+  have hbody' : natFinalEnv.HasType univs AsV.reverse
+      (probeNatZeroRuleLhsBodyV.instL vls) bodyType := by
+    simpa [AsV] using hbody
+  have hDelta0 : OnCtx AsV.reverse (natFinalEnv.IsType univs) := by
+    exact hTel'.toOnCtx (by trivial)
+  have hprobeType : probeNatZeroRuleTypeV =
+      VExpr.forallN probeNatRuleBindersV probeNatZeroRuleResultV := rfl
+  have hargs : natFinalEnv.SpineWF univs AsV.reverse
+      (VExpr.forallN AsV ResultV) argsV ResultV := by
+    have hcore := natSelfSpine (env := natFinalEnv) (univs := univs)
+      AsV ResultV []
+    have hclosed : (VExpr.forallN AsV ResultV).Closed := by
+      have ⟨⟨_, _⟩, _, htypeClosed⟩ := natFinalEnv_ordered.closed.2 hreg
+      rw [probeNatZeroRuleTypeV_eq] at htypeClosed
+      rw [hprobeType] at htypeClosed
+      simpa [AsV, ResultV, VExpr.instL_forallN] using
+        htypeClosed.instL (ls := vls)
+    rw [hclosed.liftN_eq (Nat.zero_le _)] at hcore
+    simpa [AsV, argsV, probeNatRuleBindersV,
+      VExpr.bvarRevRange] using hcore
+  have hTelLocal : natFinalEnv.OnTel univs AsV.reverse AsV := by
+    simpa using natOnTelWeakR natFinalEnv_ordered (Base := [])
+      (As := AsV) (by trivial) hTel' AsV.reverse
+  have hbodyLocal : natFinalEnv.HasType univs
+      (AsV.reverse ++ AsV.reverse)
+      (probeNatZeroRuleLhsBodyV.instL vls) bodyType :=
+    VEnv.IsDefEq.weakR natFinalEnv_ordered
+      (VEnv.CtxWF.closed natFinalEnv_ordered hDelta0) hbody' AsV.reverse
+  have hspineBody := VEnv.SpineWF.retarget hargs
+    (by simp [AsV, argsV, probeNatRuleBindersV]) bodyType
+  have hcollapseV := VEnv.IsDefEq.appN_lamN natFinalEnv_ordered
+    hTelLocal hbodyLocal hspineBody
+      (by simp [AsV, argsV, probeNatRuleBindersV])
+  have htypeShape :
+      (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls =
+        VExpr.forallN AsV ResultV := by
+    rw [probeNatZeroRuleTypeV_eq, hprobeType, VExpr.instL_forallN]
+  have hlhsLocal : natFinalEnv.HasType univs AsV.reverse
+      ((probeNatZeroRuleLhsV.instL vls).appN argsV)
+      ResultV := by
+    have hlhsWeak : natFinalEnv.HasType univs AsV.reverse
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs.instL vls)
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls) :=
+      ((natFinalEnv_ordered.defEqWF hreg).1.instL hvls).weak0
+        natFinalEnv_ordered
+    have hdeclared : natFinalEnv.SpineWF univs AsV.reverse
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls)
+        argsV ResultV := by
+      rw [htypeShape]
+      exact hargs
+    rw [← probeNatZeroRuleLhsV_eq]
+    exact hdeclared.hasType_appN hlhsWeak
+  have hcollapseV' : natFinalEnv.IsDefEq univs AsV.reverse
+      ((probeNatZeroRuleLhsV.instL vls).appN argsV)
+      ((probeNatZeroRuleLhsBodyV.instL vls).instRev argsV)
+      ResultV := by
+    have ⟨_, htype⟩ := hcollapseV.symm.uniq
+      InductiveReplayFixtures.nat_env_wf hDelta0 hlhsLocal
+    exact htype.defeqDF hcollapseV
+  have hrawV : natFinalEnv.IsDefEq univs AsV.reverse
+      ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs.instL vls)
+      ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs.instL vls)
+      ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls) :=
+    .extra hreg hvls rfl
+  have hdeclared : natFinalEnv.SpineWF univs AsV.reverse
+      ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls)
+      argsV ResultV := by
+    rw [htypeShape]
+    exact hargs
+  have happliedV := hrawV.appN_congr hdeclared
+  have hsound0V := hcollapseV'.symm.trans happliedV
+  have hsoundV := hsound0V.weakR natFinalEnv_ordered
+    (VEnv.CtxWF.closed natFinalEnv_ordered hDelta0)
+    (Gamma.map SExpr.reify)
+  have hlevels : OnCtx
+      (AsV.reverse ++ Gamma.map SExpr.reify)
+      (fun _ A => A.LevelWF univs) := by
+    have hAsLevels : ∀ A ∈ AsV, A.LevelWF univs := by
+      intro A hA
+      simp only [AsV, List.mem_map] at hA
+      obtain ⟨A0, _, rfl⟩ := hA
+      exact VExpr.LevelWF.instL hvls
+    have hGammaLevels : OnCtx (Gamma.map SExpr.reify)
+        (fun _ A => A.LevelWF univs) :=
+      natReifyLevelWFContext Gamma
+    have go : ∀ L : List VExpr,
+        (∀ A ∈ L, A.LevelWF univs) →
+        OnCtx (L ++ Gamma.map SExpr.reify)
+          (fun _ A => A.LevelWF univs) := by
+      intro L hall
+      induction L with
+      | nil => simpa using hGammaLevels
+      | cons A rest ih =>
+        exact ⟨ih (fun B hB => hall B (.tail _ hB)),
+          hall A (.head _)⟩
+    exact go AsV.reverse (by
+      intro A hA
+      exact hAsLevels A (by simpa using hA))
+  have hsoundS := SExpr.IsDefEq.mkS (natStructureEtaSound univs)
+    hsoundV hlevels
+  have hmkInst (e : VExpr) :
+      SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+    unfold vls
+    exact @SExpr.mk_instL_map_reify (natParams univs) e [level]
+  have hctx :
+      (AsV.reverse ++ Gamma.map SExpr.reify).map SExpr.mk = Delta := by
+    rw [List.map_append]
+    have hGamma : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    have hAs : AsV.reverse.map SExpr.mk = Delta0 := by
+      rw [List.map_reverse]
+      have hforward : AsV.map SExpr.mk =
+          [Motive, MinorZero, MinorSucc] := by
+        simp [AsV, Motive, MinorZero, MinorSucc,
+          probeNatRuleBindersV, hmkInst, SExpr.mkInst,
+          probeInstVParamZero]
+      rw [hforward]
+      rfl
+    rw [hAs, hGamma]
+  rw [hctx] at hsoundS
+  have hbodyCollapseV :
+      (probeNatZeroRuleLhsBodyV.instL vls).instRev argsV =
+      ((((VExpr.const ``Nat.rec [level.reify]).app (VExpr.bvar 2)).app
+        (VExpr.bvar 1)).app (VExpr.bvar 0)).app
+          (VExpr.const ``Nat.zero []) := by
+    simp [probeNatZeroRuleLhsBodyV, vls, argsV, VExpr.instRev,
+      VExpr.instL, VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+      VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+      probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift]
+  rw [hbodyCollapseV] at hsoundS
+  have hresultMk :
+      SExpr.mk ResultV = Result := by
+    simp [ResultV, Result, probeNatZeroRuleResultV, vls,
+      VExpr.instL, SExpr.mk]
+  rw [hresultMk] at hsoundS
+  simpa [Delta, Delta0, Redex, AppliedRhs, vls, argsV, hmkInst,
+    probeNatZeroRuleLhsV, probeNatRuleBindersV, VExpr.lamN,
+    VExpr.appN, SExpr.mk, SExpr.mkInst] using hsoundS
+
+/-- The generated zero match supplies the single local extension leaf used
+by the registered tower proof. -/
+theorem natZeroRuleLocalStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (probeNatZeroRuleType univs level)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+    let Redex : SExpr :=
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+        (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+          (SExpr.const ``Nat.zero [])
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+        (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+    let Result : SExpr :=
+      (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+    IsDefEqStrong Delta Redex AppliedRhs Result := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Delta : List SExpr := MinorSucc :: MinorZero :: Motive :: Gamma
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+      (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+        (SExpr.const ``Nat.zero [])
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+      (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+  let Result : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure probeNatFlatCtorZero_lookup,
+      NatGeneration.ruleCheck natRuleClosure
+        (List.mem_of_getElem? probeNatFlatCtorZero_lookup))
+  have hpat : NatPat
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0) rgen :=
+    .mk probeNatFlatCtorZero_lookup
+  let rule : Pattern.IotaRule rgen := {
+    pat := hpat
+    df := NatGeneration.rule 0 NatGeneration.flatCtors[0]
+    registered := natRule_registered probeNatFlatCtorZero_lookup
+    rhsClosed := natRuleClosure.rhs_closed probeNatFlatCtorZero_lookup
+    capturePaths := natCapturePaths NatGeneration.flatCtors[0]
+    rhsTower := natRuleRHS_tower probeNatFlatCtorZero_lookup }
+  obtain ⟨mcap, hmatch⟩ :=
+    RecursorIotaPattern.matchesS_spines
+      (rargs := [SExpr.bvar 0, SExpr.bvar 1, SExpr.bvar 2])
+      (cargs := []) (rls := [level]) (cls := []) (by rfl) (by rfl)
+  have hmatch' : (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0).MatchesS
+      Redex [level] mcap := by
+    simpa [Redex] using hmatch
+  obtain ⟨_, _, hcaps⟩ := natZeroCaptureValues univs hmatch
+  have hrhsEq : AppliedRhs = rgen.1.applyS [level] mcap := by
+    calc
+      AppliedRhs =
+          (rule.capturePaths.map mcap).foldl
+            (fun (f a : SExpr) => f.app a)
+            (SExpr.mkInst [level] rule.df.rhs) := by
+        simp [AppliedRhs, rule, hcaps]
+      _ = rgen.1.applyS [level] mcap := rule.rhsApply [level] mcap
+  have hsound : IsDefEq Delta Redex (rgen.1.applyS [level] mcap)
+      Result := by
+    have hsoundCanonical : IsDefEq Delta Redex AppliedRhs Result := by
+      simpa [Delta, Redex, AppliedRhs, Result] using
+        (natZeroRuleActionSound univs (Gamma := Gamma) level)
+    exact hrhsEq ▸ hsoundCanonical
+  let action : Pattern.Action Delta rgen Redex [level] mcap Result := {
+    pat := hpat
+    matched := hmatch'
+    dfs := []
+    defeqs := by rfl
+    checked := by simp
+    sound := hsound }
+  have hLeft := natZeroRuleBodyStrong univs (Gamma := Gamma) level hRuleType
+  have hRightCanonical :=
+    natZeroRuleAppliedStrong univs (Gamma := Gamma) level hRuleType hRhs
+  have hRight : IsDefEqStrong Delta
+      (rgen.1.applyS [level] mcap) (rgen.1.applyS [level] mcap)
+      Result := by
+    have hRightCanonical' : IsDefEqStrong Delta AppliedRhs AppliedRhs
+        Result := by
+      simpa [Delta, AppliedRhs, Result] using hRightCanonical
+    exact hrhsEq ▸ hRightCanonical'
+  have hLocal := IsDefEqStrong.extra action (by
+    simpa [Delta, Redex, Result] using hLeft) hRight
+  have hLocalCanonical : IsDefEqStrong Delta Redex AppliedRhs Result :=
+    hrhsEq.symm ▸ hLocal
+  simpa [Delta, Redex, AppliedRhs, Result] using hLocalCanonical
+
+/-- The first two applications of the zero RHS tower, in the binder
+contexts where the successive eta laws consume them. -/
+theorem natZeroRulePrefixesStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (probeNatZeroRuleType univs level)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Result : SExpr :=
+      (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+    let Head : SExpr := SExpr.mkInst [level]
+      (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs
+    let G1 : List SExpr := Motive :: Gamma
+    let G2 : List SExpr := MinorZero :: G1
+    IsDefEqStrong G1 (Head.app (SExpr.bvar 0))
+        (Head.app (SExpr.bvar 0))
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)) ∧
+      IsDefEqStrong G2
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+        (SExpr.forallE MinorSucc Result) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let Head : SExpr := SExpr.mkInst [level]
+    (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs
+  let G1 : List SExpr := Motive :: Gamma
+  let G2 : List SExpr := MinorZero :: G1
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatZeroRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  let rhoP : Lift := .skip .refl
+  have WP : Ctx.Lift' rhoP Gamma G1 := .skip .refl
+  have hRhsRaw : IsDefEqStrong Gamma Head Head
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type) := by
+    simpa only [Head, probeNatZeroRuleTypeS_eq] using hRhs
+  have hHeadG10 := natStrongWeak univs WP hRhsRaw
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, typeClosed⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorZero_lookup)
+  rw [rhsClosed.mkInstS.lift'_eq .zero,
+    typeClosed.mkInstS.lift'_eq .zero] at hHeadG10
+  have hHeadG1 : IsDefEqStrong G1 Head Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))) := by
+    simpa [Head, probeNatZeroRuleTypeS_eq, probeNatZeroRuleType,
+      Motive, MinorZero, MinorSucc, Result, NatS] using hHeadG10
+  have hMotiveTypeG1 : IsDefEqStrong G1 Motive Motive
+      (SExpr.sort motiveSort) := by
+    simpa [G1, rhoP, Motive, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs WP hMotiveType
+  have hP : IsDefEqStrong G1 (SExpr.bvar 0) (SExpr.bvar 0) Motive := by
+    have hLookup : Lookup G1 0 Motive.lift := .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hMotiveTypeG1)
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hCodP : IsDefEqStrong (Motive :: G1)
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))
+      (SExpr.sort restSort1) := by
+    simpa [G1, rhoP, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs WP.cons hRest1
+  have hResultP : IsDefEqStrong G1
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc Result)).inst (SExpr.bvar 0))
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc Result)).inst (SExpr.bvar 0))
+      (SExpr.sort restSort1) := by
+    simpa [G1, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hRest1
+  have hPrefixP0 := IsDefEqStrong.appDF
+    hMotiveTypeG1 hCodP hHeadG1 hP hResultP
+  have hPrefixP : IsDefEqStrong G1 (Head.app (SExpr.bvar 0))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)) := by
+    simpa [Head, MinorZero, MinorSucc, Result, NatS,
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hPrefixP0
+  let rhoZ : Lift := .skip .refl
+  have WZ : Ctx.Lift' rhoZ G1 G2 := .skip .refl
+  have hPrefixPG2 := natStrongWeak univs WZ hPrefixP
+  have hHeadClosed : Head.lift' rhoZ = Head := by
+    dsimp [Head]
+    exact rhsClosed.mkInstS.lift'_eq .zero
+  change IsDefEqStrong G2
+    ((Head.lift' rhoZ).app (SExpr.bvar 1))
+    ((Head.lift' rhoZ).app (SExpr.bvar 1))
+    ((SExpr.forallE MinorZero
+      (SExpr.forallE MinorSucc Result)).lift' rhoZ) at hPrefixPG2
+  rw [hHeadClosed] at hPrefixPG2
+  have hMinorZeroTypeG2 := natStrongWeak univs WZ hMinorZeroType
+  have hRest2G := natStrongWeak univs WZ.cons hRest2
+  have hZ : IsDefEqStrong G2 (SExpr.bvar 0) (SExpr.bvar 0)
+      (MinorZero.lift' rhoZ) := by
+    exact IsDefEqStrong.bvar (.zero : Lookup G2 0 MinorZero.lift)
+      (by simpa [rhoZ, SExpr.lift] using hMinorZeroTypeG2)
+  have hResultZ : IsDefEqStrong G2
+      (((SExpr.forallE MinorSucc Result).lift' rhoZ.cons).inst
+        (SExpr.bvar 0))
+      (((SExpr.forallE MinorSucc Result).lift' rhoZ.cons).inst
+        (SExpr.bvar 0))
+      (SExpr.sort restSort2) := by
+    simpa [G2, G1, rhoZ, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRest2
+  have hPrefixPZ0 := IsDefEqStrong.appDF
+    hMinorZeroTypeG2 hRest2G hPrefixPG2 hZ hResultZ
+  have hPrefixPZ : IsDefEqStrong G2
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc Result) := by
+    simpa [Head, G2, G1, rhoZ, Motive, MinorZero, MinorSucc, Result,
+      NatS, SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hPrefixPZ0
+  exact ⟨hPrefixP, hPrefixPZ⟩
+
+/-- The closed generated zero equation is the local iota action under its
+three binders, followed by three strong eta contractions on the RHS tower. -/
+theorem natZeroRuleRegistered (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (_hLhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)
+      (probeNatZeroRuleType univs level))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (probeNatZeroRuleType univs level)) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+      (probeNatZeroRuleType univs level) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 2).app (SExpr.const ``Nat.zero [])
+  let Head : SExpr := SExpr.mkInst [level]
+    (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs
+  let G1 : List SExpr := Motive :: Gamma
+  let G2 : List SExpr := MinorZero :: G1
+  let Delta : List SExpr := MinorSucc :: G2
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 2)).app
+      (SExpr.bvar 1)).app (SExpr.bvar 0)).app
+        (SExpr.const ``Nat.zero [])
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 2, SExpr.bvar 1, SExpr.bvar 0].foldl
+      (fun f a => f.app a) Head
+  have hRuleType := hRhs.isType
+  obtain ⟨ruleSort, hRuleType0⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatZeroRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType0
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, resultSort, hResultType⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  have hLocal : IsDefEqStrong Delta Redex AppliedRhs Result := by
+    simpa [Head, G2, G1, Delta, Redex, AppliedRhs, Result] using
+      natZeroRuleLocalStrong univs (Gamma := Gamma) level
+        ⟨ruleSort, hRuleType0⟩ hRhs
+  obtain ⟨hPrefixP, hPrefixPZ⟩ :=
+    natZeroRulePrefixesStrong univs (Gamma := Gamma) level
+      ⟨ruleSort, hRuleType0⟩ hRhs
+  have hLamS : IsDefEqStrong G2
+      (SExpr.lam MinorSucc Redex) (SExpr.lam MinorSucc AppliedRhs)
+      (SExpr.forallE MinorSucc Result) := by
+    exact .lamDF hMinorSuccType hResultType hResultType hLocal hLocal
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, _⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorZero_lookup)
+  have hEtaS0 := IsDefEqStrong.eta hPrefixPZ hLamS.hasType.2
+  have hEtaS : IsDefEqStrong G2
+      (SExpr.lam MinorSucc AppliedRhs)
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc Result) := by
+    simpa [Head, AppliedRhs, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaS0
+  have hSucc : IsDefEqStrong G2
+      (SExpr.lam MinorSucc Redex)
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc Result) := hLamS.trans hEtaS
+  have hLamZ : IsDefEqStrong G1
+      (SExpr.lam MinorZero (SExpr.lam MinorSucc Redex))
+      (SExpr.lam MinorZero
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0)))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)) := by
+    exact .lamDF hMinorZeroType hRest2 hRest2 hSucc hSucc
+  have hEtaZ0 := IsDefEqStrong.eta hPrefixP hLamZ.hasType.2
+  have hEtaZ : IsDefEqStrong G1
+      (SExpr.lam MinorZero
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0)))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)) := by
+    simpa [Head, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaZ0
+  have hZero : IsDefEqStrong G1
+      (SExpr.lam MinorZero (SExpr.lam MinorSucc Redex))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result)) :=
+    hLamZ.trans hEtaZ
+  have hLamP : IsDefEqStrong Gamma
+      (SExpr.lam Motive
+        (SExpr.lam MinorZero (SExpr.lam MinorSucc Redex)))
+      (SExpr.lam Motive (Head.app (SExpr.bvar 0)))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))) := by
+    exact .lamDF hMotiveType hRest1 hRest1 hZero hZero
+  have hHeadExplicit : IsDefEqStrong Gamma Head Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))) := by
+    simpa [Head, probeNatZeroRuleType, Motive, MinorZero, MinorSucc,
+      Result, NatS] using hRhs
+  have hEtaP0 := IsDefEqStrong.eta hHeadExplicit hLamP.hasType.2
+  have hEtaP : IsDefEqStrong Gamma
+      (SExpr.lam Motive (Head.app (SExpr.bvar 0))) Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero (SExpr.forallE MinorSucc Result))) := by
+    simpa [Head, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaP0
+  have hClosed := hLamP.trans hEtaP
+  simpa [Head, Motive, MinorZero, MinorSucc, Result, Redex, NatS,
+    probeNatZeroRuleType, probeNatZeroRuleLhsV_eq,
+    probeNatZeroRuleLhsV, probeNatRuleBindersV,
+    probeNatZeroRuleLhsBodyV, SExpr.mkInst, VExpr.instL,
+    VExpr.lamN, probeInstVParamZero] using hClosed
+
+/-- Strong typing of the successor redex under the four generated rule
+binders.  The recursor prefix is reconstructed from the common motive and
+minor premises, then applied to `Nat.succ pred`. -/
+theorem natSuccRuleBodyStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatSuccRuleType univs level)
+      (probeNatSuccRuleType univs level)
+      (@SExpr.sort (natParams univs) u)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+    let Redex : SExpr :=
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    let Result : SExpr :=
+      (SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    IsDefEqStrong Delta Redex Redex Result := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+      (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatSuccRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, restSort3, hRest3⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  obtain ⟨⟨natBinderSort, hNatBinderType⟩, resultSort, hResultType⟩ :=
+    hRest3.forallE_inv' (.inl rfl)
+  let G0 : List SExpr := Motive :: Gamma
+  let G00 : List SExpr := MinorZero :: G0
+  let G000 : List SExpr := MinorSucc :: G00
+  let rho3base : Lift := .skip (.skip (.skip .refl))
+  have W3base : Ctx.Lift' rho3base Gamma G000 :=
+    .skip (.skip (.skip .refl))
+  have hMotiveG000 := natStrongWeak univs W3base hMotiveType
+  have hP0 : IsDefEqStrong G000 (SExpr.bvar 2) (SExpr.bvar 2)
+      Motive := by
+    have hLookup : Lookup G000 2 Motive.lift.lift.lift :=
+      .succ (.succ .zero)
+    have hBvar := IsDefEqStrong.bvar hLookup hMotiveG000
+    simpa [G000, G00, G0, Motive, NatS,
+      SExpr.lift, SExpr.lift'] using hBvar
+  have hPZero : IsDefEqStrong G000
+      ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))
+      ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))
+      (SExpr.sort level) := by
+    simpa [SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      IsDefEqStrong.appDF (natTypeStrong univs G000) .sort hP0
+        (natZeroStrong univs G000) .sort
+  have hZeroAfterSucc : IsDefEqStrong G00
+      (SExpr.forallE MinorSucc
+        ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])))
+      (SExpr.forallE MinorSucc
+        ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])))
+      (SExpr.sort (succSort.imax level)) :=
+    .forallEDF hMinorSuccType hPZero hPZero
+  have hZeroAfterZero : IsDefEqStrong G0
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc
+          ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc
+          ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))))
+      (SExpr.sort (zeroSort.imax (succSort.imax level))) :=
+    .forallEDF hMinorZeroType hZeroAfterSucc hZeroAfterSucc
+  have hZeroRuleType0 : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc
+            ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])))))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc
+            ((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])))))
+      (SExpr.sort
+        (motiveSort.imax (zeroSort.imax (succSort.imax level)))) :=
+    .forallEDF hMotiveType hZeroAfterZero hZeroAfterZero
+  let rho4 : Lift := .skip (.skip (.skip (.skip .refl)))
+  have W4 : Ctx.Lift' rho4 Gamma Delta :=
+    .skip (.skip (.skip (.skip .refl)))
+  have hZeroRuleTypeD0 := natStrongWeak univs W4 hZeroRuleType0
+  have hZeroRuleTypeD : IsDefEqStrong Delta
+      (probeNatZeroRuleType univs level)
+      (probeNatZeroRuleType univs level)
+      (SExpr.sort
+        (motiveSort.imax (zeroSort.imax (succSort.imax level)))) := by
+    simpa [rho4, probeNatZeroRuleType, Motive, MinorZero, MinorSucc,
+      NatS, SExpr.lift, SExpr.lift'] using hZeroRuleTypeD0
+  have hRec := natRecStrongOfZeroRuleType univs (Gamma := Delta) level
+    ⟨_, hZeroRuleTypeD⟩
+  let rho3 : Lift := .skip (.skip (.skip .refl))
+  have W3 : Ctx.Lift' rho3 (Motive :: Gamma) Delta :=
+    .skip (.skip (.skip .refl))
+  let rho2 : Lift := .skip (.skip .refl)
+  have W2 : Ctx.Lift' rho2 (MinorZero :: Motive :: Gamma) Delta :=
+    .skip (.skip .refl)
+  have hMotiveTypeD : IsDefEqStrong Delta Motive Motive
+      (SExpr.sort motiveSort) := by
+    simpa [rho4, Motive, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W4 hMotiveType
+  let ZeroTy : SExpr :=
+    (SExpr.bvar 3).app (SExpr.const ``Nat.zero [])
+  let SuccTy : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 4).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 5).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  have hZeroTypeD : IsDefEqStrong Delta ZeroTy ZeroTy
+      (SExpr.sort zeroSort) := by
+    simpa [rho3, ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W3 hMinorZeroType
+  have hSuccTypeD : IsDefEqStrong Delta SuccTy SuccTy
+      (SExpr.sort succSort) := by
+    simpa [rho2, SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W2 hMinorSuccType
+  have hP : IsDefEqStrong Delta (SExpr.bvar 3) (SExpr.bvar 3) Motive := by
+    have hLookup : Lookup Delta 3 (Motive.lift.lift.lift.lift) :=
+      .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup
+      (natStrongWeak univs W4 hMotiveType)
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hZ : IsDefEqStrong Delta (SExpr.bvar 2) (SExpr.bvar 2) ZeroTy := by
+    have hLookup : Lookup Delta 2 (MinorZero.lift.lift.lift) :=
+      .succ (.succ .zero)
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hZeroTypeD)
+    simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hBvar
+  have hS : IsDefEqStrong Delta (SExpr.bvar 1) (SExpr.bvar 1) SuccTy := by
+    have hLookup : Lookup Delta 1 (MinorSucc.lift.lift) := .succ .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+        hSuccTypeD)
+    simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hPred : IsDefEqStrong Delta (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hLookup : Lookup Delta 0 NatS.lift := .zero
+    have hNat := natTypeStrong univs Delta
+    change IsDefEqStrong Delta (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact IsDefEqStrong.bvar hLookup (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  let MajorTail : SExpr :=
+    SExpr.forallE NatS ((SExpr.bvar 4).app (SExpr.bvar 0))
+  let natSort : SLevel := SLevel.instV [] VLevel.zero.succ
+  let majorTailSort : SLevel := natSort.imax level
+  have hMotiveDeep : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 4) (SExpr.bvar 4) Motive := by
+    let rho5 : Lift := .skip (.skip (.skip (.skip (.skip .refl))))
+    have W5 : Ctx.Lift' rho5 Gamma (NatS :: Delta) :=
+      .skip (.skip (.skip (.skip (.skip .refl))))
+    have hLift := natStrongWeak univs W5 hMotiveType
+    have hLookup : Lookup (NatS :: Delta) 4
+        (Motive.lift.lift.lift.lift.lift) :=
+      .succ (.succ (.succ (.succ .zero)))
+    have hBvar := IsDefEqStrong.bvar hLookup hLift
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hMajor : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: Delta)
+    change IsDefEqStrong (NatS :: Delta) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hMotiveMajor : IsDefEqStrong (NatS :: Delta)
+      ((SExpr.bvar 4).app (SExpr.bvar 0))
+      ((SExpr.bvar 4).app (SExpr.bvar 0)) (SExpr.sort level) :=
+    .appDF (natTypeStrong univs (NatS :: Delta)) .sort
+      hMotiveDeep hMajor .sort
+  have hMajorTail : IsDefEqStrong Delta MajorTail MajorTail
+      (SExpr.sort majorTailSort) := by
+    simpa [MajorTail, majorTailSort, natSort] using
+      IsDefEqStrong.forallEDF
+        (natTypeStrong univs Delta) hMotiveMajor hMotiveMajor
+  let RG1 : List SExpr := Motive :: Delta
+  let RG2 : List SExpr := MinorZero :: RG1
+  let RG3 : List SExpr := MinorSucc :: RG2
+  have hZeroTypeG : IsDefEqStrong RG1 MinorZero MinorZero
+      (SExpr.sort zeroSort) := by
+    have h := natStrongWeak univs W4.cons hMinorZeroType
+    simpa [RG1, rho4, Motive, MinorZero, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hSuccTypeG : IsDefEqStrong RG2 MinorSucc MinorSucc
+      (SExpr.sort succSort) := by
+    have h := natStrongWeak univs W4.cons.cons hMinorSuccType
+    simpa [RG2, RG1, rho4, Motive, MinorZero, MinorSucc, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hMotiveGeneric : IsDefEqStrong (NatS :: RG3)
+      (SExpr.bvar 3) (SExpr.bvar 3) Motive := by
+    let rho4g : Lift := .skip (.skip (.skip (.skip .refl)))
+    have W4g : Ctx.Lift' rho4g Delta (NatS :: RG3) :=
+      .skip (.skip (.skip (.skip .refl)))
+    have hLift := natStrongWeak univs W4g hMotiveTypeD
+    have hLookup : Lookup (NatS :: RG3) 3
+        (Motive.lift.lift.lift.lift) := .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup hLift
+    simpa [RG3, RG2, RG1, Motive, NatS,
+      SExpr.lift, SExpr.lift'] using hBvar
+  have hMajorGeneric : IsDefEqStrong (NatS :: RG3)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: RG3)
+    change IsDefEqStrong (NatS :: RG3) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hGenericResult : IsDefEqStrong (NatS :: RG3)
+      ((SExpr.bvar 3).app (SExpr.bvar 0))
+      ((SExpr.bvar 3).app (SExpr.bvar 0)) (SExpr.sort level) :=
+    .appDF (natTypeStrong univs (NatS :: RG3)) .sort
+      hMotiveGeneric hMajorGeneric .sort
+  have hMajorTailG : IsDefEqStrong RG3
+      (SExpr.forallE NatS ((SExpr.bvar 3).app (SExpr.bvar 0)))
+      (SExpr.forallE NatS ((SExpr.bvar 3).app (SExpr.bvar 0)))
+      (SExpr.sort majorTailSort) := by
+    simpa [majorTailSort, natSort] using
+      IsDefEqStrong.forallEDF
+        (natTypeStrong univs RG3) hGenericResult hGenericResult
+  have hRecAfterSuccG := IsDefEqStrong.forallEDF
+    hSuccTypeG hMajorTailG hMajorTailG
+  have hRecAfterZeroG := IsDefEqStrong.forallEDF
+    hZeroTypeG hRecAfterSuccG hRecAfterSuccG
+  have hMajorTailS : IsDefEqStrong (SuccTy :: Delta)
+      MajorTail.lift MajorTail.lift (SExpr.sort majorTailSort) := by
+    simpa [MajorTail, SuccTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := SuccTy)) hMajorTail
+  have hAfterSucc : IsDefEqStrong Delta
+      (SExpr.forallE SuccTy MajorTail.lift)
+      (SExpr.forallE SuccTy MajorTail.lift)
+      (SExpr.sort (succSort.imax majorTailSort)) :=
+    .forallEDF hSuccTypeD hMajorTailS hMajorTailS
+  have hSuccTypeZ : IsDefEqStrong (ZeroTy :: Delta)
+      SuccTy.lift SuccTy.lift (SExpr.sort succSort) := by
+    simpa [SuccTy, ZeroTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := ZeroTy)) hSuccTypeD
+  let rhoZS : Lift := .skip (.skip .refl)
+  have WZS : Ctx.Lift' rhoZS Delta
+      (SuccTy.lift :: ZeroTy :: Delta) := .skip (.skip .refl)
+  have hMajorTailZS : IsDefEqStrong (SuccTy.lift :: ZeroTy :: Delta)
+      MajorTail.lift.lift MajorTail.lift.lift
+      (SExpr.sort majorTailSort) := by
+    simpa [rhoZS, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs WZS hMajorTail
+  have hAfterSuccZ : IsDefEqStrong (ZeroTy :: Delta)
+      (SExpr.forallE SuccTy.lift MajorTail.lift.lift)
+      (SExpr.forallE SuccTy.lift MajorTail.lift.lift)
+      (SExpr.sort (succSort.imax majorTailSort)) :=
+    .forallEDF hSuccTypeZ hMajorTailZS hMajorTailZS
+  have hAfterZero : IsDefEqStrong Delta
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift))
+      (SExpr.sort (zeroSort.imax (succSort.imax majorTailSort))) :=
+    .forallEDF hZeroTypeD hAfterSuccZ hAfterSuccZ
+  have hRecP0 := IsDefEqStrong.appDF
+    hMotiveTypeD hRecAfterZeroG hRec hP hAfterZero
+  have hRecP : IsDefEqStrong Delta
+      ((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3))
+      ((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift MajorTail.lift.lift)) := by
+    simpa [RG3, RG2, RG1, ZeroTy, SuccTy, MajorTail, Motive,
+      MinorZero, MinorSucc, NatS, SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRecP0
+  have hRecPZ0 := IsDefEqStrong.appDF
+    hZeroTypeD hAfterSuccZ hRecP hZ hAfterSucc
+  have hRecPZ : IsDefEqStrong Delta
+      (((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2))
+      (((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2))
+      (SExpr.forallE SuccTy MajorTail.lift) := by
+    simpa [ZeroTy, SuccTy, MajorTail, NatS, SExpr.lift, SExpr.lift',
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hRecPZ0
+  have hRecPZS0 := IsDefEqStrong.appDF
+    hSuccTypeD hMajorTailS hRecPZ hS hMajorTail
+  have hRecPZS : IsDefEqStrong Delta
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2)).app (SExpr.bvar 1))
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2)).app (SExpr.bvar 1)) MajorTail := by
+    simpa [SuccTy, MajorTail, NatS, SExpr.lift, SExpr.lift',
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hRecPZS0
+  have hSuccPred0 := IsDefEqStrong.appDF
+    (natTypeStrong univs Delta)
+    (natTypeStrong univs (NatS :: Delta))
+    (natSuccStrong univs Delta) hPred (natTypeStrong univs Delta)
+  have hSuccPred : IsDefEqStrong Delta
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)) NatS := by
+    simpa [NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using hSuccPred0
+  have hPSuccPred : IsDefEqStrong Delta Result Result
+      (SExpr.sort level) := by
+    simpa [Result, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      IsDefEqStrong.appDF (natTypeStrong univs Delta) .sort hP
+        hSuccPred .sort
+  have hBody0 := IsDefEqStrong.appDF
+    (natTypeStrong univs Delta) hMotiveMajor hRecPZS hSuccPred hPSuccPred
+  simpa [Delta, Redex, Result, MajorTail, NatS,
+    SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+    Subst.lift, Subst.id] using hBody0
+
+/-- Apply the closed successor RHS tower to motive, minors, and predecessor. -/
+theorem natSuccRuleAppliedStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatSuccRuleType univs level)
+      (probeNatSuccRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hHead : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (probeNatSuccRuleType univs level)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+        SExpr.bvar 0].foldl (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+    let Result : SExpr :=
+      (SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    IsDefEqStrong Delta AppliedRhs AppliedRhs Result := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+      SExpr.bvar 0].foldl (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatSuccRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, _, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, _, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, _, _hRest3⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  let rho4 : Lift := .skip (.skip (.skip (.skip .refl)))
+  have W4 : Ctx.Lift' rho4 Gamma Delta :=
+    .skip (.skip (.skip (.skip .refl)))
+  let rho3 : Lift := .skip (.skip (.skip .refl))
+  have W3 : Ctx.Lift' rho3 (Motive :: Gamma) Delta :=
+    .skip (.skip (.skip .refl))
+  let rho2 : Lift := .skip (.skip .refl)
+  have W2 : Ctx.Lift' rho2 (MinorZero :: Motive :: Gamma) Delta :=
+    .skip (.skip .refl)
+  have hMotiveTypeD : IsDefEqStrong Delta Motive Motive
+      (SExpr.sort motiveSort) := by
+    simpa [rho4, Motive, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W4 hMotiveType
+  let ZeroTy : SExpr :=
+    (SExpr.bvar 3).app (SExpr.const ``Nat.zero [])
+  let SuccTy : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 4).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 5).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  have hZeroTypeD : IsDefEqStrong Delta ZeroTy ZeroTy
+      (SExpr.sort zeroSort) := by
+    simpa [rho3, ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W3 hMinorZeroType
+  have hSuccTypeD : IsDefEqStrong Delta SuccTy SuccTy
+      (SExpr.sort succSort) := by
+    simpa [rho2, SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs W2 hMinorSuccType
+  have hP : IsDefEqStrong Delta (SExpr.bvar 3) (SExpr.bvar 3) Motive := by
+    have hLookup : Lookup Delta 3 (Motive.lift.lift.lift.lift) :=
+      .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup
+      (natStrongWeak univs W4 hMotiveType)
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hZ : IsDefEqStrong Delta (SExpr.bvar 2) (SExpr.bvar 2) ZeroTy := by
+    have hLookup : Lookup Delta 2 (MinorZero.lift.lift.lift) :=
+      .succ (.succ .zero)
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hZeroTypeD)
+    simpa [ZeroTy, MinorZero, SExpr.lift, SExpr.lift'] using hBvar
+  have hS : IsDefEqStrong Delta (SExpr.bvar 1) (SExpr.bvar 1) SuccTy := by
+    have hLookup : Lookup Delta 1 (MinorSucc.lift.lift) := .succ .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using
+        hSuccTypeD)
+    simpa [SuccTy, MinorSucc, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hPred : IsDefEqStrong Delta (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs Delta
+    change IsDefEqStrong Delta (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hHeadRaw : IsDefEqStrong Gamma
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type) := by
+    simpa only [probeNatSuccRuleTypeS_eq] using hHead
+  have hHeadD0 := natStrongWeak univs W4 hHeadRaw
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, typeClosed⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorSucc_lookup)
+  rw [rhsClosed.mkInstS.lift'_eq .zero,
+    typeClosed.mkInstS.lift'_eq .zero] at hHeadD0
+  have hHeadD : IsDefEqStrong Delta
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))) := by
+    simpa [probeNatSuccRuleTypeS_eq, probeNatSuccRuleType, Motive,
+      MinorZero, MinorSucc, Result, NatS] using hHeadD0
+  let RG1 : List SExpr := Motive :: Delta
+  let RG2 : List SExpr := MinorZero :: RG1
+  let RG3 : List SExpr := MinorSucc :: RG2
+  have hZeroTypeG : IsDefEqStrong RG1 MinorZero MinorZero
+      (SExpr.sort zeroSort) := by
+    have h := natStrongWeak univs W4.cons hMinorZeroType
+    simpa [RG1, rho4, Motive, MinorZero, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hSuccTypeG : IsDefEqStrong RG2 MinorSucc MinorSucc
+      (SExpr.sort succSort) := by
+    have h := natStrongWeak univs W4.cons.cons hMinorSuccType
+    simpa [RG2, RG1, rho4, Motive, MinorZero, MinorSucc, NatS,
+      SExpr.lift, SExpr.lift'] using h
+  have hMotiveGeneric : IsDefEqStrong (NatS :: RG3)
+      (SExpr.bvar 3) (SExpr.bvar 3) Motive := by
+    let rho4g : Lift := .skip (.skip (.skip (.skip .refl)))
+    have W4g : Ctx.Lift' rho4g Delta (NatS :: RG3) :=
+      .skip (.skip (.skip (.skip .refl)))
+    have hLift := natStrongWeak univs W4g hMotiveTypeD
+    have hLookup : Lookup (NatS :: RG3) 3
+        (Motive.lift.lift.lift.lift) := .succ (.succ (.succ .zero))
+    have hBvar := IsDefEqStrong.bvar hLookup hLift
+    simpa [RG3, RG2, RG1, Motive, NatS,
+      SExpr.lift, SExpr.lift'] using hBvar
+  have hGenericPred : IsDefEqStrong (NatS :: RG3)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: RG3)
+    change IsDefEqStrong (NatS :: RG3) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hGenericSucc0 := IsDefEqStrong.appDF
+    (natTypeStrong univs (NatS :: RG3))
+    (natTypeStrong univs (NatS :: NatS :: RG3))
+    (natSuccStrong univs (NatS :: RG3)) hGenericPred
+    (natTypeStrong univs (NatS :: RG3))
+  have hGenericSucc : IsDefEqStrong (NatS :: RG3)
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)) NatS := by
+    simpa [NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using hGenericSucc0
+  have hGenericResult : IsDefEqStrong (NatS :: RG3)
+      ((SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)))
+      ((SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)))
+      (SExpr.sort level) := by
+    simpa [SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      IsDefEqStrong.appDF (natTypeStrong univs (NatS :: RG3)) .sort
+        hMotiveGeneric hGenericSucc .sort
+  let predTailSort : SLevel :=
+    (SLevel.instV [] VLevel.zero.succ).imax level
+  have hPredTailG : IsDefEqStrong RG3
+      (SExpr.forallE NatS
+        ((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))))
+      (SExpr.forallE NatS
+        ((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))))
+      (SExpr.sort predTailSort) := by
+    simpa [predTailSort] using IsDefEqStrong.forallEDF
+      (natTypeStrong univs RG3) hGenericResult hGenericResult
+  have hAfterSuccG := IsDefEqStrong.forallEDF
+    hSuccTypeG hPredTailG hPredTailG
+  have hAfterZeroG := IsDefEqStrong.forallEDF
+    hZeroTypeG hAfterSuccG hAfterSuccG
+  let PredResult : SExpr :=
+    (SExpr.bvar 4).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let PredTail : SExpr := SExpr.forallE NatS PredResult
+  have hMotivePred : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 4) (SExpr.bvar 4) Motive := by
+    let rho5 : Lift := .skip (.skip (.skip (.skip (.skip .refl))))
+    have W5 : Ctx.Lift' rho5 Gamma (NatS :: Delta) :=
+      .skip (.skip (.skip (.skip (.skip .refl))))
+    have hLift := natStrongWeak univs W5 hMotiveType
+    have hLookup : Lookup (NatS :: Delta) 4
+        (Motive.lift.lift.lift.lift.lift) :=
+      .succ (.succ (.succ (.succ .zero)))
+    have hBvar := IsDefEqStrong.bvar hLookup hLift
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hFreshPred : IsDefEqStrong (NatS :: Delta)
+      (SExpr.bvar 0) (SExpr.bvar 0) NatS := by
+    have hNat := natTypeStrong univs (NatS :: Delta)
+    change IsDefEqStrong (NatS :: Delta) (SExpr.const ``Nat [])
+      (SExpr.const ``Nat [])
+      (SExpr.mkInst [] InductiveFixtures.natType.type) at hNat
+    rw [probeNatTypeTypeV_eq] at hNat
+    exact .bvar .zero (by
+      simpa [NatS, SExpr.lift, SExpr.lift', SExpr.mkInst] using hNat)
+  have hFreshSucc0 := IsDefEqStrong.appDF
+    (natTypeStrong univs (NatS :: Delta))
+    (natTypeStrong univs (NatS :: NatS :: Delta))
+    (natSuccStrong univs (NatS :: Delta)) hFreshPred
+    (natTypeStrong univs (NatS :: Delta))
+  have hFreshSucc : IsDefEqStrong (NatS :: Delta)
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)) NatS := by
+    simpa [NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using hFreshSucc0
+  have hPredResult : IsDefEqStrong (NatS :: Delta)
+      PredResult PredResult (SExpr.sort level) := by
+    simpa [PredResult, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      IsDefEqStrong.appDF (natTypeStrong univs (NatS :: Delta)) .sort
+        hMotivePred hFreshSucc .sort
+  have hPredTail : IsDefEqStrong Delta PredTail PredTail
+      (SExpr.sort predTailSort) := by
+    simpa [PredTail, predTailSort] using IsDefEqStrong.forallEDF
+      (natTypeStrong univs Delta) hPredResult hPredResult
+  have hPredTailS : IsDefEqStrong (SuccTy :: Delta)
+      PredTail.lift PredTail.lift (SExpr.sort predTailSort) := by
+    simpa [PredTail, SuccTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := SuccTy)) hPredTail
+  have hAfterSucc : IsDefEqStrong Delta
+      (SExpr.forallE SuccTy PredTail.lift)
+      (SExpr.forallE SuccTy PredTail.lift)
+      (SExpr.sort (succSort.imax predTailSort)) :=
+    .forallEDF hSuccTypeD hPredTailS hPredTailS
+  have hSuccTypeZ : IsDefEqStrong (ZeroTy :: Delta)
+      SuccTy.lift SuccTy.lift (SExpr.sort succSort) := by
+    simpa [SuccTy, ZeroTy, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs (Ctx.Lift'.one (A := ZeroTy)) hSuccTypeD
+  let rhoZS : Lift := .skip (.skip .refl)
+  have WZS : Ctx.Lift' rhoZS Delta
+      (SuccTy.lift :: ZeroTy :: Delta) := .skip (.skip .refl)
+  have hPredTailZS : IsDefEqStrong (SuccTy.lift :: ZeroTy :: Delta)
+      PredTail.lift.lift PredTail.lift.lift
+      (SExpr.sort predTailSort) := by
+    simpa [rhoZS, SExpr.lift, ← SExpr.lift'_comp] using
+      natStrongWeak univs WZS hPredTail
+  have hAfterSuccZ : IsDefEqStrong (ZeroTy :: Delta)
+      (SExpr.forallE SuccTy.lift PredTail.lift.lift)
+      (SExpr.forallE SuccTy.lift PredTail.lift.lift)
+      (SExpr.sort (succSort.imax predTailSort)) :=
+    .forallEDF hSuccTypeZ hPredTailZS hPredTailZS
+  have hAfterZero : IsDefEqStrong Delta
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift PredTail.lift.lift))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift PredTail.lift.lift))
+      (SExpr.sort (zeroSort.imax (succSort.imax predTailSort))) :=
+    .forallEDF hZeroTypeD hAfterSuccZ hAfterSuccZ
+  have hAppP0 := IsDefEqStrong.appDF
+    hMotiveTypeD hAfterZeroG hHeadD hP hAfterZero
+  have hAppP : IsDefEqStrong Delta
+      ((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3))
+      ((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3))
+      (SExpr.forallE ZeroTy
+        (SExpr.forallE SuccTy.lift PredTail.lift.lift)) := by
+    simpa [RG3, RG2, RG1, ZeroTy, SuccTy, PredTail, PredResult,
+      Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hAppP0
+  have hAppZ0 := IsDefEqStrong.appDF
+    hZeroTypeD hAfterSuccZ hAppP hZ hAfterSucc
+  have hAppZ : IsDefEqStrong Delta
+      (((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3)).app (SExpr.bvar 2))
+      (((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3)).app (SExpr.bvar 2))
+      (SExpr.forallE SuccTy PredTail.lift) := by
+    simpa [ZeroTy, SuccTy, PredTail, PredResult, NatS,
+      SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hAppZ0
+  have hAppS0 := IsDefEqStrong.appDF
+    hSuccTypeD hPredTailS hAppZ hS hPredTail
+  have hAppS : IsDefEqStrong Delta
+      ((((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3)).app (SExpr.bvar 2)).app (SExpr.bvar 1))
+      ((((SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs).app
+          (SExpr.bvar 3)).app (SExpr.bvar 2)).app (SExpr.bvar 1))
+      PredTail := by
+    simpa [SuccTy, PredTail, PredResult, NatS,
+      SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hAppS0
+  have hFinalSucc0 := IsDefEqStrong.appDF
+    (natTypeStrong univs Delta)
+    (natTypeStrong univs (NatS :: Delta))
+    (natSuccStrong univs Delta) hPred (natTypeStrong univs Delta)
+  have hFinalSucc : IsDefEqStrong Delta
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0)) NatS := by
+    simpa [NatS, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using hFinalSucc0
+  have hFinalResult : IsDefEqStrong Delta Result Result
+      (SExpr.sort level) := by
+    simpa [Result, SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+      Subst.lift, Subst.id] using
+      IsDefEqStrong.appDF (natTypeStrong univs Delta) .sort hP
+        hFinalSucc .sort
+  have hAppPred0 := IsDefEqStrong.appDF
+    (natTypeStrong univs Delta) hPredResult hAppS hPred hFinalResult
+  simpa [Delta, AppliedRhs, Result, PredTail, PredResult, NatS,
+    SExpr.inst, SExpr.subst, Subst.one, Subst.cons,
+    Subst.lift, Subst.id] using hAppPred0
+
+/-- Weak local soundness for the successor action, proved in the closed
+generated telescope and then right-weakened into the arbitrary ambient tail. -/
+theorem natSuccRuleActionSound (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+    let Redex : SExpr :=
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+        SExpr.bvar 0].foldl (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+    let Result : SExpr :=
+      (SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    IsDefEq Delta Redex AppliedRhs Result := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Delta0 : List SExpr := [NatS, MinorSucc, MinorZero, Motive]
+  let Delta : List SExpr := Delta0 ++ Gamma
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+      (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+      SExpr.bvar 0].foldl (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let vls : List VLevel := [level.reify]
+  let argsV : List VExpr :=
+    [VExpr.bvar 3, VExpr.bvar 2, VExpr.bvar 1, VExpr.bvar 0]
+  let AsV : List VExpr :=
+    probeNatSuccRuleBindersV.map (VExpr.instL vls)
+  let ResultV : VExpr := probeNatSuccRuleResultV.instL vls
+  have hvls : ∀ l ∈ vls, l.WF univs := by
+    intro l hl
+    simp only [vls, List.mem_singleton] at hl
+    subst l
+    exact SLevel.reify_wf level
+  have hreg := natRule_registered probeNatFlatCtorSucc_lookup
+  have hlhs0 := (natFinalEnv_ordered.defEqWF hreg).1.instL hvls
+  rw [probeNatSuccRuleLhsV_eq] at hlhs0
+  unfold probeNatSuccRuleLhsV at hlhs0
+  rw [VExpr.instL_lamN] at hlhs0
+  obtain ⟨hTel, bodyType, hbody⟩ :=
+    VEnv.HasType.lamN_wf natFinalEnv_ordered (by trivial) hlhs0
+  have hTel' : natFinalEnv.OnTel univs [] AsV := by
+    simpa [AsV] using hTel
+  have hbody' : natFinalEnv.HasType univs AsV.reverse
+      (probeNatSuccRuleLhsBodyV.instL vls) bodyType := by
+    simpa [AsV] using hbody
+  have hDelta0 : OnCtx AsV.reverse (natFinalEnv.IsType univs) :=
+    hTel'.toOnCtx (by trivial)
+  have hprobeType : probeNatSuccRuleTypeV =
+      VExpr.forallN probeNatSuccRuleBindersV probeNatSuccRuleResultV := rfl
+  have hargs : natFinalEnv.SpineWF univs AsV.reverse
+      (VExpr.forallN AsV ResultV) argsV ResultV := by
+    have hcore := natSelfSpine (env := natFinalEnv) (univs := univs)
+      AsV ResultV []
+    have hclosed : (VExpr.forallN AsV ResultV).Closed := by
+      have ⟨⟨_, _⟩, _, htypeClosed⟩ := natFinalEnv_ordered.closed.2 hreg
+      rw [probeNatSuccRuleTypeV_eq] at htypeClosed
+      rw [hprobeType] at htypeClosed
+      simpa [AsV, ResultV, VExpr.instL_forallN] using
+        htypeClosed.instL (ls := vls)
+    rw [hclosed.liftN_eq (Nat.zero_le _)] at hcore
+    simpa [AsV, argsV, probeNatSuccRuleBindersV,
+      probeNatRuleBindersV, VExpr.bvarRevRange] using hcore
+  have hTelLocal : natFinalEnv.OnTel univs AsV.reverse AsV := by
+    simpa using natOnTelWeakR natFinalEnv_ordered (Base := [])
+      (As := AsV) (by trivial) hTel' AsV.reverse
+  have hbodyLocal : natFinalEnv.HasType univs
+      (AsV.reverse ++ AsV.reverse)
+      (probeNatSuccRuleLhsBodyV.instL vls) bodyType :=
+    VEnv.IsDefEq.weakR natFinalEnv_ordered
+      (VEnv.CtxWF.closed natFinalEnv_ordered hDelta0) hbody' AsV.reverse
+  have hspineBody := VEnv.SpineWF.retarget hargs
+    (by simp [AsV, argsV, probeNatSuccRuleBindersV,
+      probeNatRuleBindersV]) bodyType
+  have hcollapseV := VEnv.IsDefEq.appN_lamN natFinalEnv_ordered
+    hTelLocal hbodyLocal hspineBody
+      (by simp [AsV, argsV, probeNatSuccRuleBindersV,
+        probeNatRuleBindersV])
+  have htypeShape :
+      (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls =
+        VExpr.forallN AsV ResultV := by
+    rw [probeNatSuccRuleTypeV_eq, hprobeType, VExpr.instL_forallN]
+  have hlhsLocal : natFinalEnv.HasType univs AsV.reverse
+      ((probeNatSuccRuleLhsV.instL vls).appN argsV) ResultV := by
+    have hlhsWeak : natFinalEnv.HasType univs AsV.reverse
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs.instL vls)
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls) :=
+      ((natFinalEnv_ordered.defEqWF hreg).1.instL hvls).weak0
+        natFinalEnv_ordered
+    have hdeclared : natFinalEnv.SpineWF univs AsV.reverse
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls)
+        argsV ResultV := by
+      rw [htypeShape]
+      exact hargs
+    rw [← probeNatSuccRuleLhsV_eq]
+    exact hdeclared.hasType_appN hlhsWeak
+  have hcollapseV' : natFinalEnv.IsDefEq univs AsV.reverse
+      ((probeNatSuccRuleLhsV.instL vls).appN argsV)
+      ((probeNatSuccRuleLhsBodyV.instL vls).instRev argsV)
+      ResultV := by
+    have ⟨_, htype⟩ := hcollapseV.symm.uniq
+      InductiveReplayFixtures.nat_env_wf hDelta0 hlhsLocal
+    exact htype.defeqDF hcollapseV
+  have hrawV : natFinalEnv.IsDefEq univs AsV.reverse
+      ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs.instL vls)
+      ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs.instL vls)
+      ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls) :=
+    .extra hreg hvls rfl
+  have hdeclared : natFinalEnv.SpineWF univs AsV.reverse
+      ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls)
+      argsV ResultV := by
+    rw [htypeShape]
+    exact hargs
+  have happliedV := hrawV.appN_congr hdeclared
+  have hsound0V := hcollapseV'.symm.trans happliedV
+  have hsoundV := hsound0V.weakR natFinalEnv_ordered
+    (VEnv.CtxWF.closed natFinalEnv_ordered hDelta0)
+    (Gamma.map SExpr.reify)
+  have hlevels : OnCtx
+      (AsV.reverse ++ Gamma.map SExpr.reify)
+      (fun _ A => A.LevelWF univs) := by
+    have hAsLevels : ∀ A ∈ AsV, A.LevelWF univs := by
+      intro A hA
+      simp only [AsV, List.mem_map] at hA
+      obtain ⟨A0, _, rfl⟩ := hA
+      exact VExpr.LevelWF.instL hvls
+    have hGammaLevels : OnCtx (Gamma.map SExpr.reify)
+        (fun _ A => A.LevelWF univs) := natReifyLevelWFContext Gamma
+    have go : ∀ L : List VExpr,
+        (∀ A ∈ L, A.LevelWF univs) →
+        OnCtx (L ++ Gamma.map SExpr.reify)
+          (fun _ A => A.LevelWF univs) := by
+      intro L hall
+      induction L with
+      | nil => simpa using hGammaLevels
+      | cons A rest ih =>
+        exact ⟨ih (fun B hB => hall B (.tail _ hB)),
+          hall A (.head _)⟩
+    exact go AsV.reverse (by
+      intro A hA
+      exact hAsLevels A (by simpa using hA))
+  have hsoundS := SExpr.IsDefEq.mkS (natStructureEtaSound univs)
+    hsoundV hlevels
+  have hmkInst (e : VExpr) :
+      SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+    unfold vls
+    exact @SExpr.mk_instL_map_reify (natParams univs) e [level]
+  have hctx :
+      (AsV.reverse ++ Gamma.map SExpr.reify).map SExpr.mk = Delta := by
+    rw [List.map_append]
+    have hGamma : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    have hAs : AsV.reverse.map SExpr.mk = Delta0 := by
+      rw [List.map_reverse]
+      have hforward : AsV.map SExpr.mk =
+          [Motive, MinorZero, MinorSucc, NatS] := by
+        simp [AsV, Motive, MinorZero, MinorSucc, NatS,
+          probeNatSuccRuleBindersV, probeNatRuleBindersV,
+          hmkInst, SExpr.mkInst, probeInstVParamZero]
+      rw [hforward]
+      rfl
+    rw [hAs, hGamma]
+  rw [hctx] at hsoundS
+  have hbodyCollapseV :
+      (probeNatSuccRuleLhsBodyV.instL vls).instRev argsV =
+      ((((VExpr.const ``Nat.rec [level.reify]).app (VExpr.bvar 3)).app
+        (VExpr.bvar 2)).app (VExpr.bvar 1)).app
+          ((VExpr.const ``Nat.succ []).app (VExpr.bvar 0)) := by
+    simp [probeNatSuccRuleLhsBodyV, vls, argsV, VExpr.instRev,
+      VExpr.instL, VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+      VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+      probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift]
+  rw [hbodyCollapseV] at hsoundS
+  have hresultMk : SExpr.mk ResultV = Result := by
+    simp [ResultV, Result, probeNatSuccRuleResultV, vls,
+      VExpr.instL, SExpr.mk]
+  rw [hresultMk] at hsoundS
+  simpa [Delta, Delta0, Redex, AppliedRhs, vls, argsV, hmkInst,
+    probeNatSuccRuleLhsV, probeNatSuccRuleBindersV,
+    probeNatRuleBindersV, VExpr.lamN, VExpr.appN,
+    SExpr.mk, SExpr.mkInst] using hsoundS
+
+/-- The generated successor match packages the four-capture local action. -/
+theorem natSuccRuleLocalStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatSuccRuleType univs level)
+      (probeNatSuccRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (probeNatSuccRuleType univs level)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+    let Redex : SExpr :=
+      ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+        (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    let AppliedRhs : SExpr :=
+      [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+        SExpr.bvar 0].foldl (fun f a => f.app a)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+    let Result : SExpr :=
+      (SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    IsDefEqStrong Delta Redex AppliedRhs Result := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Delta : List SExpr := NatS :: MinorSucc :: MinorZero :: Motive :: Gamma
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+      (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+      SExpr.bvar 0].foldl (fun f a => f.app a)
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure probeNatFlatCtorSucc_lookup,
+      NatGeneration.ruleCheck natRuleClosure
+        (List.mem_of_getElem? probeNatFlatCtorSucc_lookup))
+  have hpat : NatPat
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1) rgen :=
+    .mk probeNatFlatCtorSucc_lookup
+  let rule : Pattern.IotaRule rgen := {
+    pat := hpat
+    df := NatGeneration.rule 1 NatGeneration.flatCtors[1]
+    registered := natRule_registered probeNatFlatCtorSucc_lookup
+    rhsClosed := natRuleClosure.rhs_closed probeNatFlatCtorSucc_lookup
+    capturePaths := natCapturePaths NatGeneration.flatCtors[1]
+    rhsTower := natRuleRHS_tower probeNatFlatCtorSucc_lookup }
+  obtain ⟨mcap, hmatch⟩ :=
+    RecursorIotaPattern.matchesS_spines
+      (rargs := [SExpr.bvar 1, SExpr.bvar 2, SExpr.bvar 3])
+      (cargs := [SExpr.bvar 0]) (rls := [level]) (cls := [])
+      (by rfl) (by rfl)
+  have hmatch' : (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1).MatchesS
+      Redex [level] mcap := by
+    simpa [Redex] using hmatch
+  obtain ⟨_, _, hcaps⟩ := natSuccCaptureValues univs hmatch
+  have hrhsEq : AppliedRhs = rgen.1.applyS [level] mcap := by
+    calc
+      AppliedRhs =
+          (rule.capturePaths.map mcap).foldl
+            (fun (f a : SExpr) => f.app a)
+            (SExpr.mkInst [level] rule.df.rhs) := by
+        simp [AppliedRhs, rule, hcaps]
+      _ = rgen.1.applyS [level] mcap := rule.rhsApply [level] mcap
+  have hsound : IsDefEq Delta Redex (rgen.1.applyS [level] mcap)
+      Result := by
+    have hsoundCanonical : IsDefEq Delta Redex AppliedRhs Result := by
+      simpa [Delta, Redex, AppliedRhs, Result] using
+        (natSuccRuleActionSound univs (Gamma := Gamma) level)
+    exact hrhsEq ▸ hsoundCanonical
+  let action : Pattern.Action Delta rgen Redex [level] mcap Result := {
+    pat := hpat
+    matched := hmatch'
+    dfs := []
+    defeqs := by rfl
+    checked := by simp
+    sound := hsound }
+  have hLeft := natSuccRuleBodyStrong univs (Gamma := Gamma) level hRuleType
+  have hRightCanonical :=
+    natSuccRuleAppliedStrong univs (Gamma := Gamma) level hRuleType hRhs
+  have hRight : IsDefEqStrong Delta
+      (rgen.1.applyS [level] mcap) (rgen.1.applyS [level] mcap)
+      Result := by
+    have hRightCanonical' : IsDefEqStrong Delta AppliedRhs AppliedRhs
+        Result := by
+      simpa [Delta, AppliedRhs, Result] using hRightCanonical
+    exact hrhsEq ▸ hRightCanonical'
+  have hLocal := IsDefEqStrong.extra action (by
+    simpa [Delta, Redex, Result] using hLeft) hRight
+  have hLocalCanonical : IsDefEqStrong Delta Redex AppliedRhs Result :=
+    hrhsEq.symm ▸ hLocal
+  simpa [Delta, Redex, AppliedRhs, Result] using hLocalCanonical
+
+/-- The three proper prefixes of the four-argument successor RHS tower. -/
+theorem natSuccRulePrefixesStrong (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (hRuleType : ∃ u, @IsDefEqStrong (natParams univs) Gamma
+      (probeNatSuccRuleType univs level)
+      (probeNatSuccRuleType univs level)
+      (@SExpr.sort (natParams univs) u))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (probeNatSuccRuleType univs level)) :
+    letI : Params := natParams univs
+    let NatS : SExpr := SExpr.const ``Nat []
+    let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+    let MinorZero : SExpr :=
+      (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+    let MinorSucc : SExpr :=
+      SExpr.forallE NatS <|
+        SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+          (SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+    let Result : SExpr :=
+      (SExpr.bvar 3).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+    let Head : SExpr := SExpr.mkInst [level]
+      (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs
+    let G1 : List SExpr := Motive :: Gamma
+    let G2 : List SExpr := MinorZero :: G1
+    let G3 : List SExpr := MinorSucc :: G2
+    IsDefEqStrong G1 (Head.app (SExpr.bvar 0))
+        (Head.app (SExpr.bvar 0))
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))) ∧
+      IsDefEqStrong G2
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)) ∧
+      IsDefEqStrong G3
+        (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          (SExpr.bvar 0))
+        (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          (SExpr.bvar 0))
+        (SExpr.forallE NatS Result) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let Head : SExpr := SExpr.mkInst [level]
+    (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs
+  let G1 : List SExpr := Motive :: Gamma
+  let G2 : List SExpr := MinorZero :: G1
+  let G3 : List SExpr := MinorSucc :: G2
+  obtain ⟨ruleSort, hRuleType⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatSuccRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, restSort3, hRest3⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  let rhoP : Lift := .skip .refl
+  have WP : Ctx.Lift' rhoP Gamma G1 := .skip .refl
+  have hRhsRaw : IsDefEqStrong Gamma Head Head
+      (SExpr.mkInst [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type) := by
+    simpa only [Head, probeNatSuccRuleTypeS_eq] using hRhs
+  have hHeadG10 := natStrongWeak univs WP hRhsRaw
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, typeClosed⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorSucc_lookup)
+  rw [rhsClosed.mkInstS.lift'_eq .zero,
+    typeClosed.mkInstS.lift'_eq .zero] at hHeadG10
+  have hHeadG1 : IsDefEqStrong G1 Head Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))) := by
+    simpa [Head, probeNatSuccRuleTypeS_eq, probeNatSuccRuleType,
+      Motive, MinorZero, MinorSucc, Result, NatS] using hHeadG10
+  have hMotiveTypeG1 : IsDefEqStrong G1 Motive Motive
+      (SExpr.sort motiveSort) := by
+    simpa [G1, rhoP, Motive, NatS, SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs WP hMotiveType
+  have hP : IsDefEqStrong G1 (SExpr.bvar 0) (SExpr.bvar 0) Motive := by
+    have hLookup : Lookup G1 0 Motive.lift := .zero
+    have hBvar := IsDefEqStrong.bvar hLookup (by
+      simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hMotiveTypeG1)
+    simpa [Motive, NatS, SExpr.lift, SExpr.lift'] using hBvar
+  have hCodP : IsDefEqStrong (Motive :: G1)
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))
+      (SExpr.sort restSort1) := by
+    simpa [G1, rhoP, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift'] using
+      natStrongWeak univs WP.cons hRest1
+  have hResultP : IsDefEqStrong G1
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc
+          (SExpr.forallE NatS Result))).inst (SExpr.bvar 0))
+      ((SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc
+          (SExpr.forallE NatS Result))).inst (SExpr.bvar 0))
+      (SExpr.sort restSort1) := by
+    simpa [G1, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hRest1
+  have hPrefixP0 := IsDefEqStrong.appDF
+    hMotiveTypeG1 hCodP hHeadG1 hP hResultP
+  have hPrefixP : IsDefEqStrong G1 (Head.app (SExpr.bvar 0))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))) := by
+    simpa [Head, MinorZero, MinorSucc, Result, NatS,
+      SExpr.inst, SExpr.subst, Subst.one, Subst.cons, Subst.lift,
+      Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hPrefixP0
+  let rhoZ : Lift := .skip .refl
+  have WZ : Ctx.Lift' rhoZ G1 G2 := .skip .refl
+  have hPrefixPG2 := natStrongWeak univs WZ hPrefixP
+  have hHeadClosedZ : Head.lift' rhoZ = Head := by
+    dsimp [Head]
+    exact rhsClosed.mkInstS.lift'_eq .zero
+  change IsDefEqStrong G2
+    ((Head.lift' rhoZ).app (SExpr.bvar 1))
+    ((Head.lift' rhoZ).app (SExpr.bvar 1))
+    ((SExpr.forallE MinorZero
+      (SExpr.forallE MinorSucc
+        (SExpr.forallE NatS Result))).lift' rhoZ) at hPrefixPG2
+  rw [hHeadClosedZ] at hPrefixPG2
+  have hMinorZeroTypeG2 := natStrongWeak univs WZ hMinorZeroType
+  have hRest2G := natStrongWeak univs WZ.cons hRest2
+  have hZ : IsDefEqStrong G2 (SExpr.bvar 0) (SExpr.bvar 0)
+      (MinorZero.lift' rhoZ) :=
+    IsDefEqStrong.bvar (.zero : Lookup G2 0 MinorZero.lift) (by
+      simpa [rhoZ, SExpr.lift] using hMinorZeroTypeG2)
+  have hResultZ : IsDefEqStrong G2
+      (((SExpr.forallE MinorSucc
+        (SExpr.forallE NatS Result)).lift' rhoZ.cons).inst
+          (SExpr.bvar 0))
+      (((SExpr.forallE MinorSucc
+        (SExpr.forallE NatS Result)).lift' rhoZ.cons).inst
+          (SExpr.bvar 0))
+      (SExpr.sort restSort2) := by
+    simpa [G2, G1, rhoZ, Motive, MinorZero, MinorSucc, Result, NatS,
+      SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRest2
+  have hPrefixPZ0 := IsDefEqStrong.appDF
+    hMinorZeroTypeG2 hRest2G hPrefixPG2 hZ hResultZ
+  have hPrefixPZ : IsDefEqStrong G2
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)) := by
+    simpa [Head, G2, G1, rhoZ, Motive, MinorZero, MinorSucc, Result,
+      NatS, SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hPrefixPZ0
+  let rhoS : Lift := .skip .refl
+  have WS : Ctx.Lift' rhoS G2 G3 := .skip .refl
+  have hPrefixPZG3 := natStrongWeak univs WS hPrefixPZ
+  have hHeadClosedS : Head.lift' rhoS = Head := by
+    dsimp [Head]
+    exact rhsClosed.mkInstS.lift'_eq .zero
+  change IsDefEqStrong G3
+    (((Head.lift' rhoS).app (SExpr.bvar 2)).app (SExpr.bvar 1))
+    (((Head.lift' rhoS).app (SExpr.bvar 2)).app (SExpr.bvar 1))
+    ((SExpr.forallE MinorSucc
+      (SExpr.forallE NatS Result)).lift' rhoS) at hPrefixPZG3
+  rw [hHeadClosedS] at hPrefixPZG3
+  have hMinorSuccTypeG3 := natStrongWeak univs WS hMinorSuccType
+  have hRest3G := natStrongWeak univs WS.cons hRest3
+  have hS : IsDefEqStrong G3 (SExpr.bvar 0) (SExpr.bvar 0)
+      (MinorSucc.lift' rhoS) :=
+    IsDefEqStrong.bvar (.zero : Lookup G3 0 MinorSucc.lift) (by
+      simpa [rhoS, SExpr.lift] using hMinorSuccTypeG3)
+  have hResultS : IsDefEqStrong G3
+      (((SExpr.forallE NatS Result).lift' rhoS.cons).inst
+        (SExpr.bvar 0))
+      (((SExpr.forallE NatS Result).lift' rhoS.cons).inst
+        (SExpr.bvar 0))
+      (SExpr.sort restSort3) := by
+    simpa [G3, G2, G1, rhoS, Motive, MinorZero, MinorSucc, Result,
+      NatS, SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hRest3
+  have hPrefixPZS0 := IsDefEqStrong.appDF
+    hMinorSuccTypeG3 hRest3G hPrefixPZG3 hS hResultS
+  have hPrefixPZS : IsDefEqStrong G3
+      (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        (SExpr.bvar 0))
+      (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        (SExpr.bvar 0))
+      (SExpr.forallE NatS Result) := by
+    simpa [Head, G3, G2, G1, rhoS, Motive, MinorZero, MinorSucc,
+      Result, NatS, SExpr.lift, SExpr.lift', SExpr.inst, SExpr.subst,
+      Subst.one, Subst.cons, Subst.lift, Subst.id,
+      probeCancelUnderOne, probeCancelUnderTwo] using hPrefixPZS0
+  exact ⟨hPrefixP, hPrefixPZ, hPrefixPZS⟩
+
+/-- The closed generated successor equation, assembled from its local action
+and four strong eta contractions. -/
+theorem natSuccRuleRegistered (univs : Nat)
+    {Gamma : List (@SExpr (natParams univs))}
+    (level : @SLevel (natParams univs))
+    (_hLhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)
+      (probeNatSuccRuleType univs level))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (probeNatSuccRuleType univs level)) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)
+      (@SExpr.mkInst (natParams univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+      (probeNatSuccRuleType univs level) := by
+  letI : Params := natParams univs
+  let NatS : SExpr := SExpr.const ``Nat []
+  let Motive : SExpr := SExpr.forallE NatS (SExpr.sort level)
+  let MinorZero : SExpr :=
+    (SExpr.bvar 0).app (SExpr.const ``Nat.zero [])
+  let MinorSucc : SExpr :=
+    SExpr.forallE NatS <|
+      SExpr.forallE ((SExpr.bvar 2).app (SExpr.bvar 0)) <|
+        (SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))
+  let Result : SExpr :=
+    (SExpr.bvar 3).app
+      ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let Head : SExpr := SExpr.mkInst [level]
+    (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs
+  let G1 : List SExpr := Motive :: Gamma
+  let G2 : List SExpr := MinorZero :: G1
+  let G3 : List SExpr := MinorSucc :: G2
+  let Delta : List SExpr := NatS :: G3
+  let Redex : SExpr :=
+    ((((SExpr.const ``Nat.rec [level]).app (SExpr.bvar 3)).app
+      (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))
+  let AppliedRhs : SExpr :=
+    [SExpr.bvar 3, SExpr.bvar 2, SExpr.bvar 1,
+      SExpr.bvar 0].foldl (fun f a => f.app a) Head
+  have hRuleType := hRhs.isType
+  obtain ⟨ruleSort, hRuleType0⟩ := hRuleType
+  have hRuleType' : IsDefEqStrong Gamma
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))))
+      (SExpr.sort ruleSort) := by
+    simpa [probeNatSuccRuleType, Motive, MinorZero, MinorSucc, Result,
+      NatS] using hRuleType0
+  obtain ⟨⟨motiveSort, hMotiveType⟩, restSort1, hRest1⟩ :=
+    hRuleType'.forallE_inv' (.inl rfl)
+  obtain ⟨⟨zeroSort, hMinorZeroType⟩, restSort2, hRest2⟩ :=
+    hRest1.forallE_inv' (.inl rfl)
+  obtain ⟨⟨succSort, hMinorSuccType⟩, restSort3, hRest3⟩ :=
+    hRest2.forallE_inv' (.inl rfl)
+  obtain ⟨⟨natSort, hNatType⟩, resultSort, hResultType⟩ :=
+    hRest3.forallE_inv' (.inl rfl)
+  have hLocal : IsDefEqStrong Delta Redex AppliedRhs Result := by
+    simpa [Head, G3, G2, G1, Delta, Redex, AppliedRhs, Result] using
+      natSuccRuleLocalStrong univs (Gamma := Gamma) level
+        ⟨ruleSort, hRuleType0⟩ hRhs
+  obtain ⟨hPrefixP, hPrefixPZ, hPrefixPZS⟩ :=
+    natSuccRulePrefixesStrong univs (Gamma := Gamma) level
+      ⟨ruleSort, hRuleType0⟩ hRhs
+  obtain ⟨⟨_, _⟩, ⟨rhsClosed, _⟩⟩ :=
+    natFinalEnv_ordered.closed.2
+      (natRule_registered probeNatFlatCtorSucc_lookup)
+  have hLamN : IsDefEqStrong G3
+      (SExpr.lam NatS Redex) (SExpr.lam NatS AppliedRhs)
+      (SExpr.forallE NatS Result) := by
+    exact .lamDF hNatType hResultType hResultType hLocal hLocal
+  have hEtaN0 := IsDefEqStrong.eta hPrefixPZS hLamN.hasType.2
+  have hEtaN : IsDefEqStrong G3
+      (SExpr.lam NatS AppliedRhs)
+      (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        (SExpr.bvar 0))
+      (SExpr.forallE NatS Result) := by
+    simpa [Head, AppliedRhs, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaN0
+  have hPred : IsDefEqStrong G3
+      (SExpr.lam NatS Redex)
+      (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+        (SExpr.bvar 0))
+      (SExpr.forallE NatS Result) := hLamN.trans hEtaN
+  have hLamS : IsDefEqStrong G2
+      (SExpr.lam MinorSucc (SExpr.lam NatS Redex))
+      (SExpr.lam MinorSucc
+        (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          (SExpr.bvar 0)))
+      (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)) := by
+    exact .lamDF hMinorSuccType hRest3 hRest3 hPred hPred
+  have hEtaS0 := IsDefEqStrong.eta hPrefixPZ hLamS.hasType.2
+  have hEtaS : IsDefEqStrong G2
+      (SExpr.lam MinorSucc
+        (((Head.app (SExpr.bvar 2)).app (SExpr.bvar 1)).app
+          (SExpr.bvar 0)))
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)) := by
+    simpa [Head, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaS0
+  have hSucc : IsDefEqStrong G2
+      (SExpr.lam MinorSucc (SExpr.lam NatS Redex))
+      ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0))
+      (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)) :=
+    hLamS.trans hEtaS
+  have hLamZ : IsDefEqStrong G1
+      (SExpr.lam MinorZero
+        (SExpr.lam MinorSucc (SExpr.lam NatS Redex)))
+      (SExpr.lam MinorZero
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0)))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))) := by
+    exact .lamDF hMinorZeroType hRest2 hRest2 hSucc hSucc
+  have hEtaZ0 := IsDefEqStrong.eta hPrefixP hLamZ.hasType.2
+  have hEtaZ : IsDefEqStrong G1
+      (SExpr.lam MinorZero
+        ((Head.app (SExpr.bvar 1)).app (SExpr.bvar 0)))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))) := by
+    simpa [Head, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaZ0
+  have hZero : IsDefEqStrong G1
+      (SExpr.lam MinorZero
+        (SExpr.lam MinorSucc (SExpr.lam NatS Redex)))
+      (Head.app (SExpr.bvar 0))
+      (SExpr.forallE MinorZero
+        (SExpr.forallE MinorSucc (SExpr.forallE NatS Result))) :=
+    hLamZ.trans hEtaZ
+  have hLamP : IsDefEqStrong Gamma
+      (SExpr.lam Motive
+        (SExpr.lam MinorZero
+          (SExpr.lam MinorSucc (SExpr.lam NatS Redex))))
+      (SExpr.lam Motive (Head.app (SExpr.bvar 0)))
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))) := by
+    exact .lamDF hMotiveType hRest1 hRest1 hZero hZero
+  have hHeadExplicit : IsDefEqStrong Gamma Head Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))) := by
+    simpa [Head, probeNatSuccRuleType, Motive, MinorZero, MinorSucc,
+      Result, NatS] using hRhs
+  have hEtaP0 := IsDefEqStrong.eta hHeadExplicit hLamP.hasType.2
+  have hEtaP : IsDefEqStrong Gamma
+      (SExpr.lam Motive (Head.app (SExpr.bvar 0))) Head
+      (SExpr.forallE Motive
+        (SExpr.forallE MinorZero
+          (SExpr.forallE MinorSucc (SExpr.forallE NatS Result)))) := by
+    simpa [Head, SExpr.lift, SExpr.lift',
+      rhsClosed.mkInstS.lift_eq] using hEtaP0
+  have hClosed := hLamP.trans hEtaP
+  simpa [Head, Motive, MinorZero, MinorSucc, Result, Redex, NatS,
+    probeNatSuccRuleType, probeNatSuccRuleLhsV_eq,
+    probeNatSuccRuleLhsV, probeNatSuccRuleBindersV,
+    probeNatRuleBindersV, probeNatSuccRuleLhsBodyV,
+    SExpr.mkInst, VExpr.instL, VExpr.lamN,
+    probeInstVParamZero] using hClosed
+
+/-- Dispatch every registered equation of the concrete Nat environment to
+its generated zero or successor proof. -/
+theorem natRegistered (univs : Nat)
+    {df : VDefEq} {ls : List (@SLevel (natParams univs))}
+    {Gamma : List (@SExpr (natParams univs))}
+    (hreg : natFinalEnv.defeqs df) (hlen : ls.length = df.uvars)
+    (hLhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) ls df.lhs)
+      (@SExpr.mkInst (natParams univs) ls df.lhs)
+      (@SExpr.mkInst (natParams univs) ls df.type))
+    (hRhs : @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) ls df.rhs)
+      (@SExpr.mkInst (natParams univs) ls df.rhs)
+      (@SExpr.mkInst (natParams univs) ls df.type)) :
+    @IsDefEqStrong (natParams univs) Gamma
+      (@SExpr.mkInst (natParams univs) ls df.lhs)
+      (@SExpr.mkInst (natParams univs) ls df.rhs)
+      (@SExpr.mkInst (natParams univs) ls df.type) := by
+  letI : Params := natParams univs
+  rw [natFinalEnv_defeqs_iff] at hreg
+  obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hreg
+  have hj' : j = 0 ∨ j = 1 := by
+    obtain ⟨hlt, _⟩ := List.getElem?_eq_some_iff.mp hj
+    have hlength : NatGeneration.generatedRules.length = 2 := rfl
+    omega
+  rcases hj' with rfl | rfl
+  · have hdf := Option.some.inj
+      (probeNatGeneratedRuleZero_lookup.symm.trans hj)
+    subst df
+    change ls.length = 1 at hlen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hlen
+    have hLhs' : IsDefEqStrong Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)
+        (probeNatZeroRuleType univs level) := by
+      simpa only [probeNatZeroRuleTypeS_eq] using hLhs
+    have hRhs' : IsDefEqStrong Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).rhs)
+        (probeNatZeroRuleType univs level) := by
+      simpa only [probeNatZeroRuleTypeS_eq] using hRhs
+    simpa only [probeNatZeroRuleTypeS_eq] using
+      natZeroRuleRegistered univs level hLhs' hRhs'
+  · have hdf := Option.some.inj
+      (probeNatGeneratedRuleSucc_lookup.symm.trans hj)
+    subst df
+    change ls.length = 1 at hlen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hlen
+    have hLhs' : IsDefEqStrong Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)
+        (probeNatSuccRuleType univs level) := by
+      simpa only [probeNatSuccRuleTypeS_eq] using hLhs
+    have hRhs' : IsDefEqStrong Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).rhs)
+        (probeNatSuccRuleType univs level) := by
+      simpa only [probeNatSuccRuleTypeS_eq] using hRhs
+    simpa only [probeNatSuccRuleTypeS_eq] using
+      natSuccRuleRegistered univs level hLhs' hRhs'
+
+/-- The complete concrete semantic bridge for the generated Nat fixture. -/
+noncomputable def natSemantic (univs : Nat) :
+    letI : Params := natParams univs
+    Params.Semantic := by
+  letI : Params := natParams univs
+  exact {
+  structureEta := by
+    intro rule levels Gamma params major hreg
+    exact (natFinalEnv_no_structEta rule hreg).elim
+  ctor := by
+    intro c ci ls Gamma hci hlen cl
+    exact natCtor univs hci hlen cl
+  defn := by
+    intro c r hpat
+    exact (natPat_no_const univs hpat).elim
+  iotaRule := by
+    intro rec major ctor arity r hpat
+    exact natIotaRule univs hpat
+  iotaSite := by
+    intro rec major ctor arity r Gamma A majorTerm recLs ctorLs
+      recArgs ctorArgs mcap rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+    exact natIotaSite univs rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+  registered := by
+    intro df ls Gamma hreg hlen hLhs hRhs
+    exact natRegistered univs hreg hlen hLhs hRhs }
+
+/-! ## D0b semantic certificate -/
+
+theorem d0StructureEtaSound (univs : Nat) :
+    @Params.StructureEtaSound (d0Params univs) := by
+  letI : Params := d0Params univs
+  intro rule levels Gamma params major hreg
+  exact (d0Env_no_structEta rule hreg).elim
+
+def D0ContextValid (univs : Nat)
+    (Gamma : List (@SExpr (d0Params univs))) : Prop :=
+  letI : Params := d0Params univs
+  OnCtx (Gamma.map SExpr.reify) (d0Env.IsType univs)
+
+def D0TypesDefEq (univs : Nat) {Gamma : List (@SExpr (d0Params univs))}
+    (A B : @SExpr (d0Params univs)) : Prop :=
+  letI : Params := d0Params univs
+  ∃ u, IsDefEq Gamma A B (.sort u)
+
+theorem d0TypeUniq (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {x A B : @SExpr (d0Params univs)}
+    (hGamma : D0ContextValid univs Gamma)
+    (hxA : @IsDefEq (d0Params univs) Gamma x x A)
+    (hxB : @IsDefEq (d0Params univs) Gamma x x B) :
+    D0TypesDefEq (Gamma := Gamma) univs A B := by
+  letI : Params := d0Params univs
+  change OnCtx (Gamma.map SExpr.reify) (d0Env.IsType univs) at hGamma
+  change ∃ u, IsDefEq Gamma A B (.sort u)
+  have hxA' := hxA.reify hGamma
+  have hxB' := hxB.reify hGamma
+  obtain ⟨u, hAB⟩ := hxA'.uniq d0Env_wf hGamma hxB'
+  have hlevels := (VEnv.CtxStrong.strong d0Env_ordered hGamma).levelWF
+  have hAB' := SExpr.IsDefEq.mkS (d0StructureEtaSound univs) hAB hlevels
+  have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  rw [hctx] at hAB'
+  refine ⟨SLevel.mk u, ?_⟩
+  simpa only [SExpr.mk_reify, SExpr.mk] using hAB'
+
+theorem d0TypesTrans (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {A B C : @SExpr (d0Params univs)}
+    (hGamma : D0ContextValid univs Gamma)
+    (hAB : D0TypesDefEq (Gamma := Gamma) univs A B)
+    (hBC : D0TypesDefEq (Gamma := Gamma) univs B C) :
+    D0TypesDefEq (Gamma := Gamma) univs A C := by
+  letI : Params := d0Params univs
+  obtain ⟨u, hAB⟩ := hAB
+  obtain ⟨v, hBC⟩ := hBC
+  obtain ⟨w, huv⟩ := d0TypeUniq univs hGamma hAB.hasType.2 hBC.hasType.1
+  exact ⟨u, hAB.trans (huv.symm.defeqDF hBC)⟩
+
+theorem d0TypesInst (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {D B B' e : @SExpr (d0Params univs)}
+    (hBB' : D0TypesDefEq (Gamma := D :: Gamma) univs B B')
+    (he : @IsDefEq (d0Params univs) Gamma e e D) :
+    D0TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (d0Params univs) B e)
+      (@SExpr.inst (d0Params univs) B' e) := by
+  letI : Params := d0Params univs
+  obtain ⟨u, hBB'⟩ := hBB'
+  have hsubst := hBB'.subst
+    (Ctx.Subst.one IsDefEq.weak' IsDefEq.bvar he)
+  change IsDefEq Gamma (B.inst e) (B'.inst e) (.sort u) at hsubst
+  exact ⟨u, hsubst⟩
+
+theorem d0ForallEInv (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {A B A' B' : @SExpr (d0Params univs)}
+    (hGamma : D0ContextValid univs Gamma)
+    (hPi : D0TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d0Params univs) A B)
+      (@SExpr.forallE (d0Params univs) A' B')) :
+    D0TypesDefEq (Gamma := Gamma) univs A A' ∧
+      D0TypesDefEq (Gamma := A :: Gamma) univs B B' := by
+  letI : Params := d0Params univs
+  change OnCtx (Gamma.map SExpr.reify) (d0Env.IsType univs) at hGamma
+  obtain ⟨_, hPi⟩ := hPi
+  have hPi' := hPi.reify hGamma
+  have hPiU : d0Env.IsDefEqU univs (Gamma.map SExpr.reify)
+      (.forallE A.reify B.reify) (.forallE A'.reify B'.reify) :=
+    ⟨_, hPi'⟩
+  obtain ⟨⟨u, hA⟩, v, hB⟩ :=
+    VEnv.IsDefEqU.forallE_inv d0Env_wf hGamma hPiU
+  have hlevels := (VEnv.CtxStrong.strong d0Env_ordered hGamma).levelWF
+  have hA' := SExpr.IsDefEq.mkS (d0StructureEtaSound univs) hA hlevels
+  have hAlevels := (hA.levelWF hlevels).1
+  have hB' := SExpr.IsDefEq.mkS (d0StructureEtaSound univs) hB
+    ⟨hlevels, hAlevels⟩
+  have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  constructor
+  · refine ⟨SLevel.mk u, ?_⟩
+    simpa only [hctx, SExpr.mk_reify, SExpr.mk] using hA'
+  · refine ⟨SLevel.mk v, ?_⟩
+    simpa only [List.map_cons, hctx, SExpr.mk_reify, SExpr.mk] using hB'
+
+structure D0SpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    (D B e : @SExpr (d0Params univs))
+    (es : List (@SExpr (d0Params univs)))
+    (R : @SExpr (d0Params univs)) where
+  domain : @SExpr (d0Params univs)
+  codomain : @SExpr (d0Params univs)
+  domainEq : D0TypesDefEq (Gamma := Gamma) univs D domain
+  codomainEq : D0TypesDefEq (Gamma := D :: Gamma) univs B codomain
+  argument : @IsDefEq (d0Params univs) Gamma e e domain
+  tail : @SpineWF (d0Params univs) Gamma
+    (@SExpr.inst (d0Params univs) codomain e) es R
+
+theorem d0SpineConsView_nonempty (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {D B Head e R : @SExpr (d0Params univs)}
+    {es : List (@SExpr (d0Params univs))}
+    (hGamma : D0ContextValid univs Gamma)
+    (hHead : D0TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d0Params univs) D B) Head)
+    (H : @SpineWF (d0Params univs) Gamma Head (e :: es) R) :
+    Nonempty (D0SpineConsView (Gamma := Gamma) univs D B e es R) := by
+  letI : Params := d0Params univs
+  generalize hargsEq : e :: es = args at H
+  induction H generalizing D B e es with
+  | nil => cases hargsEq
+  | @cons _ domain _ _ codomain harg htail ih =>
+    cases hargsEq
+    obtain ⟨hdom, hbody⟩ := d0ForallEInv univs hGamma hHead
+    exact ⟨{
+      domain := domain
+      codomain := codomain
+      domainEq := hdom
+      codomainEq := hbody
+      argument := harg
+      tail := htail }⟩
+  | @conv _ Head' u _ _ hconv htail ih =>
+    exact ih (d0TypesTrans univs hGamma hHead ⟨u, hconv⟩) hargsEq
+  | @ret _ _ R' _ _ htail hret ih =>
+    let ⟨view⟩ := ih hHead hargsEq
+    exact ⟨{ view with tail := .ret view.tail hret }⟩
+
+noncomputable def d0SpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {D B Head e R : @SExpr (d0Params univs)}
+    {es : List (@SExpr (d0Params univs))}
+    (hGamma : D0ContextValid univs Gamma)
+    (hHead : D0TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d0Params univs) D B) Head)
+    (H : @SpineWF (d0Params univs) Gamma Head (e :: es) R) :
+    D0SpineConsView (Gamma := Gamma) univs D B e es R :=
+  Classical.choice (d0SpineConsView_nonempty univs hGamma hHead H)
+
+theorem D0SpineConsView.argumentExpected (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {D B e R : @SExpr (d0Params univs)}
+    {es : List (@SExpr (d0Params univs))}
+    (view : D0SpineConsView (Gamma := Gamma) univs D B e es R) :
+    @IsDefEq (d0Params univs) Gamma e e D := by
+  letI : Params := d0Params univs
+  obtain ⟨_, hdom⟩ := view.domainEq
+  exact hdom.symm.defeqDF view.argument
+
+theorem D0SpineConsView.restEq (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {D B e R : @SExpr (d0Params univs)}
+    {es : List (@SExpr (d0Params univs))}
+    (view : D0SpineConsView (Gamma := Gamma) univs D B e es R) :
+    D0TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (d0Params univs) B e)
+      (@SExpr.inst (d0Params univs) view.codomain e) :=
+  d0TypesInst univs view.codomainEq (view.argumentExpected univs)
+
+theorem d0PathSpineOfSpineWF (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {alpha : Type}
+    {value type : alpha → @SExpr (d0Params univs)}
+    {A B : @SExpr (d0Params univs)} {paths : List alpha}
+    (hGamma : D0ContextValid univs Gamma)
+    (htyped : ∀ path, @IsDefEq (d0Params univs) Gamma
+      (value path) (value path) (type path))
+    (H : @SpineWF (d0Params univs) Gamma A (paths.map value) B) :
+    @PathSpineWF (d0Params univs) Gamma alpha value type A paths B := by
+  letI : Params := d0Params univs
+  generalize hargs : paths.map value = args at H
+  induction H generalizing paths with
+  | nil =>
+    have hpaths : paths = [] := by simpa using hargs
+    subst paths
+    exact .nil
+  | @cons e domain es result codomain harg htail ih =>
+    cases paths with
+    | nil => simp at hargs
+    | cons path paths =>
+      simp only [List.map_cons, List.cons.injEq] at hargs
+      obtain ⟨hvalue, hrest⟩ := hargs
+      subst e
+      obtain ⟨_, hdomain⟩ :=
+        d0TypeUniq univs hGamma (htyped path) harg
+      exact .cons hdomain (ih hrest)
+  | @conv Head Head' u es result hHead htail ih =>
+    exact .conv hHead (ih hargs)
+  | @ret Head es result result' u htail hresult ih =>
+    exact .ret (ih hargs) hresult
+
+theorem d0ZeroCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (d0Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d0Params univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0).Path →
+      @SExpr (d0Params univs)}
+    (H : @Pattern.MatchesS (d0Params univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0)
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ``Nat.zero ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs = [] ∧
+      (natCapturePaths NatGeneration.flatCtors[0]).map mcap =
+        recArgs.reverse := by
+  letI : Params := d0Params univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, -⟩ := matchesS_varN_foldr hctor
+    have hctorArgs : ctorArgs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorArgs
+    refine ⟨hrecLen, rfl, ?_⟩
+    rw [natZeroCapturePaths]
+    change
+      ((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl).map
+          (Sum.elim recCap ctorCap) = recArgs.reverse
+    simpa [List.map_map, Function.comp_def] using hrecValues
+
+theorem d0SuccCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (d0Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d0Params univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1).Path →
+      @SExpr (d0Params univs)}
+    (H : @Pattern.MatchesS (d0Params univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1)
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ``Nat.succ ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs.length = 1 ∧
+      (natCapturePaths NatGeneration.flatCtors[1]).map mcap =
+        recArgs.reverse ++ ctorArgs.reverse := by
+  letI : Params := d0Params univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, hctorValues⟩ := matchesS_varN_foldr hctor
+    refine ⟨hrecLen, hctorLen, ?_⟩
+    rw [natSuccCapturePaths]
+    change
+      (((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl ++
+          (Pattern.varNPaths (.const ``Nat.succ) 1).map Sum.inr).map
+        (Sum.elim recCap ctorCap)) = recArgs.reverse ++ ctorArgs.reverse
+    simpa [List.map_append, List.map_map, Function.comp_def,
+      hrecValues, hctorValues]
+
+def d0ProbeNatZeroRuleType (univs : Nat)
+    (level : @SLevel (d0Params univs)) : @SExpr (d0Params univs) :=
+  letI : Params := d0Params univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))))
+
+theorem d0ProbeNatZeroRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (d0Params univs)) :
+    @SExpr.mkInst (d0Params univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type =
+      d0ProbeNatZeroRuleType univs level := by
+  rw [probeNatZeroRuleTypeV_eq]
+  rfl
+
+def d0ProbeNatSuccRuleType (univs : Nat)
+    (level : @SLevel (d0Params univs)) : @SExpr (d0Params univs) :=
+  letI : Params := d0Params univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        (SExpr.forallE (SExpr.const ``Nat [])
+          ((SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))))))
+
+theorem d0ProbeNatSuccRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (d0Params univs)) :
+    @SExpr.mkInst (d0Params univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type =
+      d0ProbeNatSuccRuleType univs level := by
+  rw [probeNatSuccRuleTypeV_eq]
+  rfl
+
+theorem d0IotaRule_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d0Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    Nonempty (@Pattern.IotaRule (d0Params univs)
+      rec major ctor arity r) := by
+  letI : Params := d0Params univs
+  change D0Pat _ _ at H
+  cases H with
+  | iota H =>
+    let oldRule := natIotaRule univs H
+    rcases oldRule with
+      ⟨oldPat, df, registered, rhsClosed, capturePaths, rhsTower⟩
+    exact ⟨{
+      pat := D0Pat.iota oldPat
+      df := df
+      registered := natFinalEnv_le_d0Env.defeqs registered
+      rhsClosed := rhsClosed
+      capturePaths := capturePaths
+      rhsTower := rhsTower }⟩
+
+noncomputable def d0IotaRule (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d0Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    @Pattern.IotaRule (d0Params univs) rec major ctor arity r :=
+  Classical.choice (d0IotaRule_nonempty univs H)
+
+theorem d0NatRecEnvLookup :
+    d0Env.constants ``Nat.rec =
+      some (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType) :=
+  natFinalEnv_le_d0Env.constants InductiveReplayFixtures.nat_rec_env_lookup
+
+theorem d0NatZeroEnvLookup :
+    d0Env.constants ``Nat.zero =
+      some InductiveFixtures.natType.ctors[0].toVConstant :=
+  natFinalEnv_le_d0Env.constants (by rfl)
+
+theorem d0NatSuccEnvLookup :
+    d0Env.constants ``Nat.succ =
+      some InductiveFixtures.natType.ctors[1].toVConstant :=
+  natFinalEnv_le_d0Env.constants InductiveReplayFixtures.nat_succ_env_lookup
+
+theorem natRule_rhs_ne_d0Def {i : Nat}
+    {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    (NatGeneration.rule i constructor).rhs ≠ d0DefVal.toDefEq.rhs := by
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, _⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl
+  · have hc := Option.some.inj
+      (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+  · have hc := Option.some.inj
+      (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+
+theorem d0Def_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (d0Params univs) d0DefVal.name) : False := by
+  letI : Params := d0Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hc := cl.cl.2.1
+  change d0Classify d0DefVal.name = some cl.cl.1 at hc
+  have hcl : cl.cl.1 = .symb 0 := by
+    simpa [d0Classify] using hc.symm
+  rw [hcl] at hshape
+  simp [ctorLike] at hshape
+
+theorem d0Ctor_name_ne_def (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d0Params univs) c) :
+    c ≠ d0DefVal.name := by
+  intro hc
+  subst c
+  exact d0Def_not_ctor univs cl
+
+@[simp] theorem d0Expr_context_roundtrip (univs : Nat)
+    (Gamma : List (@SExpr (d0Params univs))) :
+    (Gamma.map (d0ToNatExpr univs)).map (natToD0Expr univs) = Gamma := by
+  simp [List.map_map, Function.comp_def]
+
+@[simp] theorem d0Level_list_roundtrip (univs : Nat)
+    (ls : List (@SLevel (d0Params univs))) :
+    (ls.map (d0ToNatLevel univs)).map (natToD0Level univs) = ls := by
+  simp [List.map_map, Function.comp_def]
+
+theorem d0NatTypeStrong (univs : Nat)
+    (Gamma : List (@SExpr (d0Params univs))) :
+    @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.const (d0Params univs) ``Nat [])
+      (@SExpr.const (d0Params univs) ``Nat [])
+      (@SExpr.sort (d0Params univs)
+        (@SLevel.succ (d0Params univs) (@SLevel.zero (d0Params univs)))) := by
+  have H := natStrongToD0 univs
+    (natTypeStrong univs (Gamma.map (d0ToNatExpr univs)))
+  simp only [d0Expr_context_roundtrip, natToD0Expr_const,
+    natToD0Expr_mkInst, List.map_nil] at H
+  change @IsDefEqStrong (d0Params univs) Gamma
+    (@SExpr.const (d0Params univs) ``Nat [])
+    (@SExpr.const (d0Params univs) ``Nat [])
+    (@SExpr.sort (d0Params univs)
+      (@SLevel.succ (d0Params univs) (@SLevel.zero (d0Params univs)))) at H
+  exact H
+
+theorem d0NatZeroStrong (univs : Nat)
+    (Gamma : List (@SExpr (d0Params univs))) :
+    @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.const (d0Params univs) ``Nat.zero [])
+      (@SExpr.const (d0Params univs) ``Nat.zero [])
+      (@SExpr.const (d0Params univs) ``Nat []) := by
+  have H := natStrongToD0 univs
+    (natZeroStrong univs (Gamma.map (d0ToNatExpr univs)))
+  simpa only [d0Expr_context_roundtrip, natToD0Expr_const,
+    List.map_nil] using H
+
+noncomputable def d0Ctor (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (d0Params univs))}
+    {Gamma : List (@SExpr (d0Params univs))}
+    (hci : d0Env.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (d0Params univs) c) :
+    letI : Params := d0Params univs
+    {F : CtorBundle c cl //
+      IsDefEqStrong Gamma (SExpr.mkInst ls ci.type)
+        (F.rhs ls) (.sort F.u)} := by
+  letI : Params := d0Params univs
+  let oldGamma := Gamma.map (d0ToNatExpr univs)
+  let oldLs := ls.map (d0ToNatLevel univs)
+  have oldHci : natFinalEnv.constants c = some ci :=
+    d0Env_constants_old (d0Ctor_name_ne_def univs cl) hci
+  have oldLen : oldLs.length = ci.uvars := by
+    simpa [oldLs] using hlen
+  let oldF : @CtorBundle (natParams univs) c (d0CtorToNat univs cl) :=
+    (natCtor univs (Gamma := oldGamma) (ls := oldLs)
+      oldHci oldLen (d0CtorToNat univs cl)).1
+  have oldProof : @IsDefEqStrong (natParams univs) oldGamma
+      (@SExpr.mkInst (natParams univs) oldLs ci.type)
+      (@CtorBundle.rhs (natParams univs) c (d0CtorToNat univs cl)
+        oldF oldLs)
+      (@SExpr.sort (natParams univs)
+        (@CtorBundle.u (natParams univs) c (d0CtorToNat univs cl) oldF)) :=
+    (natCtor univs (Gamma := oldGamma) (ls := oldLs)
+      oldHci oldLen (d0CtorToNat univs cl)).2
+  let newF := natCtorBundleToD0 univs cl oldF
+  refine ⟨newF, ?_⟩
+  have H := natStrongToD0 univs oldProof
+  dsimp only [oldGamma, oldLs] at H
+  simp only [d0Expr_context_roundtrip,
+    natToD0Expr_mkInst, natToD0Expr_sort] at H
+  rw [natCtorBundleToD0_rhs univs cl oldF
+    (ls.map (d0ToNatLevel univs))] at H
+  simpa only [newF, d0Level_list_roundtrip,
+    natCtorBundleToD0_u] using H
+
+theorem d0DefStrong (univs : Nat)
+    (Gamma : List (@SExpr (d0Params univs))) :
+    @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.const (d0Params univs) d0DefVal.name [])
+      (@SExpr.const (d0Params univs) ``Nat.zero [])
+      (@SExpr.const (d0Params univs) ``Nat []) := by
+  letI : Params := d0Params univs
+  let r : (Pattern.const d0DefVal.name).RHS ×
+      (Pattern.const d0DefVal.name).Check :=
+    (.fixed d0DefVal.value d0DefClosed, .true)
+  let action : Pattern.Action Gamma r (.const d0DefVal.name []) []
+      Empty.elim (.const ``Nat []) := {
+    pat := D0Pat.defn
+    matched := by
+      refine cast ?_ (@Pattern.MatchesS.const (d0Params univs)
+        d0DefVal.name [])
+      congr 1
+      funext path
+      exact Empty.elim path
+    dfs := []
+    defeqs := rfl
+    checked := by simp
+    sound := by
+      have H := @IsDefEq.extra (d0Params univs) d0DefVal.toDefEq Gamma []
+        VEnv.addDefEq_self rfl
+      change IsDefEq Gamma (.const d0DefVal.name [])
+        (.const ``Nat.zero []) (.const ``Nat []) at H
+      exact H }
+  let F : ∀ cl : CtorBundle.IsCtor d0DefVal.name,
+      CtorBundle d0DefVal.name cl := fun cl =>
+    (d0Def_not_ctor univs cl).elim
+  refine @IsDefEqStrong.defn (d0Params univs) d0DefVal.name
+    d0DefVal.toVConstant Gamma []
+    (@SLevel.succ (d0Params univs) (@SLevel.zero (d0Params univs))) r
+    d0Env_d0Def_lookup rfl ?_ F ?_ action ?_
+  · change IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+      (.sort (.succ .zero))
+    exact d0NatTypeStrong univs Gamma
+  · intro cl
+    exact (d0Def_not_ctor univs cl).elim
+  · change IsDefEqStrong Gamma (.const ``Nat.zero [])
+      (.const ``Nat.zero []) (.const ``Nat [])
+    exact d0NatZeroStrong univs Gamma
+
+theorem d0Defn (univs : Nat) {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : (d0Params univs).Pat (.const c) r) :
+    ∃ (value : VExpr) (closed : value.Closed),
+      r = (.fixed value closed, .true) ∧
+      ∀ {ci : VConstant} {ls : List (@SLevel (d0Params univs))}
+        {Gamma : List (@SExpr (d0Params univs))},
+        d0Env.constants c = some ci → ls.length = ci.uvars →
+        @IsDefEqStrong (d0Params univs) Gamma
+          (@SExpr.const (d0Params univs) c ls)
+          (@SExpr.mkInst (d0Params univs) ls value)
+          (@SExpr.mkInst (d0Params univs) ls ci.type) := by
+  letI : Params := d0Params univs
+  change D0Pat (.const c) r at H
+  cases H with
+  | iota H => exact (natPat_no_const univs H).elim
+  | defn =>
+    refine ⟨d0DefVal.value, d0DefClosed, rfl, ?_⟩
+    intro ci ls Gamma hci hlen
+    have hci' : ci = d0DefVal.toVConstant :=
+      Option.some.inj (hci.symm.trans d0Env_d0Def_lookup)
+    subst ci
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.const (d0Params univs) d0DefVal.name [])
+      (@SExpr.const (d0Params univs) ``Nat.zero [])
+      (@SExpr.const (d0Params univs) ``Nat [])
+    exact d0DefStrong univs Gamma
+
+theorem d0Registered (univs : Nat)
+    {df : VDefEq} {ls : List (@SLevel (d0Params univs))}
+    {Gamma : List (@SExpr (d0Params univs))}
+    (hreg : d0Env.defeqs df) (hlen : ls.length = df.uvars)
+    (_hLhs : @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.mkInst (d0Params univs) ls df.lhs)
+      (@SExpr.mkInst (d0Params univs) ls df.lhs)
+      (@SExpr.mkInst (d0Params univs) ls df.type))
+    (_hRhs : @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.mkInst (d0Params univs) ls df.rhs)
+      (@SExpr.mkInst (d0Params univs) ls df.rhs)
+      (@SExpr.mkInst (d0Params univs) ls df.type)) :
+    @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.mkInst (d0Params univs) ls df.lhs)
+      (@SExpr.mkInst (d0Params univs) ls df.rhs)
+      (@SExpr.mkInst (d0Params univs) ls df.type) := by
+  rw [d0Env_defeqs_iff] at hreg
+  rcases hreg with hdef | hold
+  · subst df
+    change ls.length = 0 at hlen
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d0Params univs) Gamma
+      (@SExpr.const (d0Params univs) d0DefVal.name [])
+      (@SExpr.const (d0Params univs) ``Nat.zero [])
+      (@SExpr.const (d0Params univs) ``Nat [])
+    exact d0DefStrong univs Gamma
+  · let oldGamma := Gamma.map (d0ToNatExpr univs)
+    let oldLs := ls.map (d0ToNatLevel univs)
+    have oldLen : oldLs.length = df.uvars := by
+      simpa [oldLs] using hlen
+    have oldLhs : @IsDefEqStrong (natParams univs) oldGamma
+        (@SExpr.mkInst (natParams univs) oldLs df.lhs)
+        (@SExpr.mkInst (natParams univs) oldLs df.lhs)
+        (@SExpr.mkInst (natParams univs) oldLs df.type) := by
+      letI : Params := natParams univs
+      letI : Params.Semantic := natSemantic univs
+      exact Params.Semantic.closedHasTypeStrong
+        (natFinalEnv_ordered.defEqWF hold).1
+    have oldRhs : @IsDefEqStrong (natParams univs) oldGamma
+        (@SExpr.mkInst (natParams univs) oldLs df.rhs)
+        (@SExpr.mkInst (natParams univs) oldLs df.rhs)
+        (@SExpr.mkInst (natParams univs) oldLs df.type) := by
+      letI : Params := natParams univs
+      letI : Params.Semantic := natSemantic univs
+      exact Params.Semantic.closedHasTypeStrong
+        (natFinalEnv_ordered.defEqWF hold).2
+    have oldEq := natRegistered univs hold oldLen oldLhs oldRhs
+    have H := natStrongToD0 univs oldEq
+    dsimp only [oldGamma, oldLs] at H
+    simpa only [d0Expr_context_roundtrip, natToD0Expr_mkInst,
+      d0Level_list_roundtrip] using H
+
+theorem d0IotaSite_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d0Params univs))}
+    {A majorTerm : @SExpr (d0Params univs)}
+    {recLs ctorLs : List (@SLevel (d0Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d0Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d0Params univs)}
+    (rule : @Pattern.IotaRule (d0Params univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d0Params univs))
+    (captureTyping : @Pattern.CaptureTyping (d0Params univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : D0ContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (d0Params univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (d0Params univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (d0Params univs) Gamma
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs)))
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (d0Params univs) Gamma A A
+      (@SExpr.sort (d0Params univs) u)) :
+    Nonempty (@Pattern.IotaReductionSite (d0Params univs) Gamma rec major ctor
+      arity r rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping) := by
+  letI : Params := d0Params univs
+  have hpatD0 := rule.pat
+  change D0Pat _ _ at hpatD0
+  have hpat : NatPat (RecursorIotaPattern rec major ctor arity) r := by
+    cases hpatD0 with
+    | iota H => exact H
+  obtain ⟨i, constructor, hentry, hpattern, -⟩ :=
+    VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration hpat
+  change RecursorIotaPattern rec major ctor arity =
+    RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor) at hpattern
+  obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure hentry,
+      NatGeneration.ruleCheck natRuleClosure (List.mem_of_getElem? hentry))
+  have Hgen : NatPat
+      (RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+        (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+        (NatGeneration.ruleArgArity constructor)) rgen := .mk hentry
+  have hr : r ≍ rgen :=
+    (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+      hpat Hgen .refl (Pattern.inter_self _)).2.2
+  have hr' : r = rgen := eq_of_heq hr
+  subst r
+  rcases rule with
+    ⟨rulePat, df, ruleRegistered, rhsClosed, capturePaths, rhsTower⟩
+  change NatGeneration.ruleRHS natRuleClosure hentry =
+    Pattern.RHS.appN (.fixed df.rhs rhsClosed)
+      (capturePaths.map fun path => .var path) at rhsTower
+  rw [natRuleRHS_tower hentry] at rhsTower
+  obtain ⟨hrhs, hpaths⟩ := rhsFixedAppN_inj rhsTower
+  subst capturePaths
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  have hregD0 := ruleRegistered
+  change d0Env.defeqs df at hregD0
+  have hreg : natFinalEnv.defeqs df := by
+    rw [d0Env_defeqs_iff] at hregD0
+    rcases hregD0 with hnew | hold
+    · subst df
+      exact (natRule_rhs_ne_d0Def hentry hrhs).elim
+    · exact hold
+  rw [natFinalEnv_defeqs_iff] at hreg
+  obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hreg
+  have hj' : j = 0 ∨ j = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hj
+    have : NatGeneration.generatedRules.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl <;> rcases hj' with rfl | rfl
+  all_goals
+    first
+    | have hc := Option.some.inj
+        (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    | have hc := Option.some.inj
+        (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    first
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleZero_lookup.symm.trans hj)
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleSucc_lookup.symm.trans hj)
+    subst df
+  all_goals (try simp at hrhs ⊢)
+  case inl.inl =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatZeroRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.zero := by
+      rw [← hc]
+      exact probeNatZeroCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      d0NatRecEnvLookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      (ci := InductiveFixtures.natType.ctors[0].toVConstant) d0NatZeroEnvLookup
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgs, hcaptures⟩ :=
+      d0ZeroCaptureValues univs matched
+    rw [hctorArgs] at typing matched redexSelf ⊢
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const d0NatRecEnvLookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := d0TypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := d0SpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := d0SpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := d0SpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := d0SpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := d0TypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero [])) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := d0TypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := d0TypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := d0TypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app (SExpr.const ``Nat.zero [])) A (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelTwoLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (d0ProbeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc]
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope .nil))
+    have hplainExplicit : SpineWF Gamma (d0ProbeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        [motive, minorZero, minorSucc] A := by
+      rw [d0ProbeNatZeroRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        ((natCapturePaths NatGeneration.flatCtors[0]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := d0PathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (d0Env_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : d0Env.HasType univs (Gamma.map SExpr.reify)
+        (probeNatZeroRuleLhsV.instL vls)
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls) := by
+      rw [← probeNatZeroRuleLhsV_eq]
+      exact hlhs.weak0 d0Env_ordered
+    unfold probeNatZeroRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf d0Env_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hcoreV : d0Env.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN (probeNatRuleBindersV.map (VExpr.instL vls))
+          (probeNatZeroRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify]
+        (VExpr.instRev (probeNatZeroRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [d0Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst,
+          VExpr.inst_eq, probeReifySubstOne] using
+          hzeroV
+      refine .cons ?_ .nil
+      simpa [d0Params, vls, VExpr.instL, SExpr.reify,
+        SExpr.reify_subst,
+        SExpr.reify_inst, VExpr.inst_eq, VExpr.instN_eq,
+        VExpr.Subst.liftN,
+        probeReifySubstOne, probeReifySubstLift] using
+        hsuccV
+    have hspineV := hcoreV
+    have hspineBody := VEnv.SpineWF.retarget hspineV
+      (by simp [probeNatRuleBindersV])
+      bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN d0Env_ordered
+      hTel hbody hspineBody (by simp [probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong d0Env_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (d0StructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (d0Params univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatZeroRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          (VExpr.const ``Nat.zero [])) := by
+      simp [probeNatZeroRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelTwoLifts, VExpr.inst_lift]
+      simpa only [VExpr.liftN_zero] using
+        probeVCancelTwoLifts motive.reify minorZero.reify minorSucc.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify])) := by
+      rw [probeNatZeroRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatZeroRuleLhsV,
+        probeNatRuleBindersV, probeNatZeroRuleLhsBodyV,
+        VExpr.lamN, VExpr.appN,
+        probeVCancelTwoLifts, VExpr.inst_lift, SExpr.mk,
+        SExpr.mkInst] using
+        hcollapseS
+    obtain ⟨_, hcollapseType⟩ := d0TypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatZeroRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+  case inl.inr =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs)).elim
+  case inr.inl =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs.symm)).elim
+  case inr.inr =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatSuccRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.succ := by
+      rw [← hc]
+      exact probeNatSuccCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      d0NatRecEnvLookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      d0NatSuccEnvLookup
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgsLen, hcaptures⟩ :=
+      d0SuccCaptureValues univs matched
+    obtain ⟨pred, rfl⟩ := List.length_eq_one_iff.mp hctorArgsLen
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const d0NatRecEnvLookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := d0TypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := d0SpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := d0SpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := d0SpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := d0SpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hctorCanonical : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (SExpr.mkInst [] InductiveFixtures.natType.ctors[1].type) :=
+      .const d0NatSuccEnvLookup rfl
+    rw [probeNatSuccCtorTypeV_eq] at hctorCanonical
+    have hctorCanonical' : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (.forallE (.const ``Nat []) (.const ``Nat [])) := by
+      simpa [SExpr.mkInst] using hctorCanonical
+    have hctorType := d0TypeUniq univs hGamma
+      hctorCanonical' typing.ctorHead
+    let predView := d0SpineConsView univs hGamma hctorType typing.ctorSpine
+    have hpred := predView.argumentExpected univs
+    have hpred' : IsDefEq Gamma pred pred (.const ``Nat []) := by
+      simpa using hpred
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := d0TypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred)) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := d0TypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := d0TypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := d0TypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app ((SExpr.const ``Nat.succ []).app pred)) A
+        (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelThreeLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (d0ProbeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred]
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope (.cons hpred' .nil)))
+    have hplainExplicit : SpineWF Gamma (d0ProbeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        [motive, minorZero, minorSucc, pred] A := by
+      rw [d0ProbeNatSuccRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        ((natCapturePaths NatGeneration.flatCtors[1]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := d0PathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (d0Env_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : d0Env.HasType univs (Gamma.map SExpr.reify)
+        (probeNatSuccRuleLhsV.instL vls)
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls) := by
+      rw [← probeNatSuccRuleLhsV_eq]
+      exact hlhs.weak0 d0Env_ordered
+    unfold probeNatSuccRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf d0Env_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hpredV := hpred'.reify hGamma
+    change d0Env.IsDefEq univs (Gamma.map SExpr.reify)
+      pred.reify pred.reify _ at hpredV
+    have hcoreV : d0Env.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN
+          (probeNatSuccRuleBindersV.map (VExpr.instL vls))
+          (probeNatSuccRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]
+        (VExpr.instRev (probeNatSuccRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [d0Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, VExpr.inst_eq, probeReifySubstOne] using hzeroV
+      refine .cons ?_ ?_
+      · simpa [d0Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, SExpr.reify_inst, VExpr.inst_eq,
+          VExpr.instN_eq, VExpr.Subst.liftN, probeReifySubstOne,
+          probeReifySubstLift] using hsuccV
+      refine .cons ?_ .nil
+      simpa [d0Params, vls, VExpr.instL, VExpr.inst, SExpr.reify] using hpredV
+    have hspineBody := VEnv.SpineWF.retarget hcoreV
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV]) bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN d0Env_ordered
+      hTel hbody hspineBody
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong d0Env_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (d0StructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (d0Params univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatSuccRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          ((VExpr.const ``Nat.succ []).app pred.reify)) := by
+      simp [probeNatSuccRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift]
+      constructor
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelThreeLifts motive.reify minorZero.reify
+            minorSucc.reify pred.reify
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelTwoLifts minorZero.reify minorSucc.reify pred.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify])) := by
+      rw [probeNatSuccRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatSuccRuleLhsV,
+        probeNatSuccRuleBindersV, probeNatRuleBindersV,
+        probeNatSuccRuleLhsBodyV, VExpr.lamN, VExpr.appN,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift,
+        SExpr.mk, SExpr.mkInst] using hcollapseS
+    obtain ⟨_, hcollapseType⟩ := d0TypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatSuccRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+noncomputable def d0IotaSite (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d0Params univs))}
+    {A majorTerm : @SExpr (d0Params univs)}
+    {recLs ctorLs : List (@SLevel (d0Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d0Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d0Params univs)}
+    (rule : @Pattern.IotaRule (d0Params univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d0Params univs))
+    (captureTyping : @Pattern.CaptureTyping (d0Params univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : D0ContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (d0Params univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (d0Params univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (d0Params univs) Gamma
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs)))
+      (@SExpr.app (d0Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d0Params univs) f a)
+          (@SExpr.const (d0Params univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (d0Params univs) Gamma A A
+      (@SExpr.sort (d0Params univs) u)) :
+    @Pattern.IotaReductionSite (d0Params univs) Gamma rec major ctor arity r
+      rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping :=
+  Classical.choice (d0IotaSite_nonempty univs rule captureType captureTyping
+    hGamma typing matched redexSelf AType)
+
+/-- The complete D0b bridge: generated Nat iota plus the checked `d0def`
+unfolding, all against the extended environment. -/
+noncomputable def d0Semantic (univs : Nat) :
+    letI : Params := d0Params univs
+    Params.Semantic := by
+  letI : Params := d0Params univs
+  exact {
+  structureEta := by
+    intro rule levels Gamma params major hreg
+    exact (d0Env_no_structEta rule hreg).elim
+  ctor := by
+    intro c ci ls Gamma hci hlen cl
+    exact d0Ctor univs hci hlen cl
+  defn := by
+    intro c r hpat
+    exact d0Defn univs hpat
+  iotaRule := by
+    intro rec major ctor arity r hpat
+    exact d0IotaRule univs hpat
+  iotaSite := by
+    intro rec major ctor arity r Gamma A majorTerm recLs ctorLs
+      recArgs ctorArgs mcap rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+    exact d0IotaSite univs rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+  registered := by
+    intro df ls Gamma hreg hlen hLhs hRhs
+    exact d0Registered univs hreg hlen hLhs hRhs }
+
+/-! ## Concrete δ-rank certificates
+
+The adequacy fixpoint unfolds definitions under an outer induction on this
+rank.  The generated Nat inventory has no constant-headed definition rules;
+the D0 extension has exactly `d0def ≡ Nat.zero`, so its body lives at rank
+zero below the definition head at rank one. -/
+
+/-- Literal δ-rank for D0.  Non-definition heads sit at rank zero. -/
+def d0DeltaRankFn : Name → Nat :=
+  fun n => if n = ``d0def then 1 else 0
+
+theorem d0DeltaRankFn_nat : d0DeltaRankFn ``Nat ≤ 0 := by decide
+
+theorem d0DeltaRankFn_natZero : d0DeltaRankFn ``Nat.zero ≤ 0 := by
+  decide
+
+theorem d0NatTypeLookup :
+    d0Env.constants ``Nat = some InductiveFixtures.natType.toVConstant :=
+  natFinalEnv_le_d0Env.constants InductiveReplayFixtures.nat_type_env_lookup
+
+/-- `Nat : Type` at rank zero, at every positive stratification depth. -/
+theorem d0NatCertR (univs : Nat) :
+    letI : Params := d0Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d0DeltaRankFn Gamma
+        (.const ``Nat []) (.sort (.instV [] (.succ .zero))) true (n + 1) 0 := by
+  letI : Params := d0Params univs
+  intro Gamma n
+  exact .base (.const d0NatTypeLookup rfl d0DeltaRankFn_nat
+    (.base .sort'))
+
+/-- `Nat.zero : Nat` at rank zero, the certificate consumed by `d0def`. -/
+theorem d0ZeroCertR (univs : Nat) :
+    letI : Params := d0Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d0DeltaRankFn Gamma
+        (.const ``Nat.zero []) (.const ``Nat []) true 2 0 := by
+  letI : Params := d0Params univs
+  intro Gamma
+  exact .base (.const d0NatZeroEnvLookup rfl d0DeltaRankFn_natZero
+    (d0NatCertR univs Gamma 0))
+
+/-- The iota-only Nat fixture has no definitional-unfold obligations. -/
+def natDeltaRank (univs : Nat) :
+    letI : Params := natParams univs
+    Params.DeltaRank := by
+  letI : Params := natParams univs
+  refine ⟨d0DeltaRankFn, ?_⟩
+  intro c ci value closed ls Gamma hpat hreg hlen
+  exact (natPat_no_const univs hpat).elim
+
+/-- The D0 fixture's checked δ-rank certificate. -/
+def d0DeltaRank (univs : Nat) :
+    letI : Params := d0Params univs
+    Params.DeltaRank := by
+  letI : Params := d0Params univs
+  refine ⟨d0DeltaRankFn, ?_⟩
+  intro c ci value closed ls Gamma hpat hreg hlen
+  change D0Pat _ _ at hpat
+  cases hpat with
+  | iota h => exact (natPat_no_const univs h).elim
+  | defn =>
+    obtain rfl := Option.some.inj (d0Env_d0Def_lookup.symm.trans hreg)
+    obtain rfl := List.length_eq_zero_iff.mp hlen
+    exact ⟨2, 0, by decide, d0ZeroCertR univs Gamma⟩
+
+/-- End-to-end D0a smoke theorem: the generated Nat fixture supplies every
+semantic certificate required by the experimental sort-injectivity bridge. -/
+theorem natSortInvS (univs : Nat) {Gamma : List VExpr} {u v : VLevel}
+    (hGamma : OnCtx Gamma (natFinalEnv.IsType univs))
+    (h : natFinalEnv.IsDefEqU univs Gamma (.sort u) (.sort v)) : u ≈ v := by
+  letI : Params := natParams univs
+  letI : Params.Semantic := natSemantic univs
+  exact VEnv.IsDefEqU.sort_invS hGamma h
+
+/-- End-to-end D0b endpoint for the combined L4L-16/17 deliverable. -/
+theorem d0SortInvS (univs : Nat) {Gamma : List VExpr} {u v : VLevel}
+    (hGamma : OnCtx Gamma (d0Env.IsType univs))
+    (h : d0Env.IsDefEqU univs Gamma (.sort u) (.sort v)) : u ≈ v := by
+  letI : Params := d0Params univs
+  letI : Params.Semantic := d0Semantic univs
+  exact VEnv.IsDefEqU.sort_invS hGamma h
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD0.d0SortInvS' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_3,
+ probeNatGeneratedRuleSucc_lookup._native.native_decide.ax_1_1,
+ probeNatGeneratedRuleZero_lookup._native.native_decide.ax_1_1,
+ probeNatRecTypeV_eq._native.native_decide.ax_1_1,
+ probeNatRuleRhs_ne._native.native_decide.ax_1_1,
+ probeNatSuccCtorName._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleRecName._native.native_decide.ax_1_1,
+ probeNatSuccRuleTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ probeNatZeroCtorName._native.native_decide.ax_1_1,
+ probeNatZeroRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatZeroRuleRecName._native.native_decide.ax_1_1,
+ probeNatZeroRuleTypeV_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d0SortInvS
+
+
+end SemanticCertificates
+
+end ParamsD0
+end SExpr
+end Lean4Lean
diff --git a/Lean4Lean/Experimental/SExprParamsD1.lean b/Lean4Lean/Experimental/SExprParamsD1.lean
new file mode 100644
index 00000000..576fc67d
--- /dev/null
+++ b/Lean4Lean/Experimental/SExprParamsD1.lean
@@ -0,0 +1,3031 @@
+import Lean4Lean.Experimental.SExprParamsD0
+
+/-!
+# L4L-16D1: mutual definitions over the D0 fixture
+
+This module extends the kernel-checked D0 instance
+(`Lean4Lean/Experimental/SExprParamsD0.lean`) with the next staged slice of
+live-environment coverage: a checked `mutualDef` declaration block.  The two
+new definitions form an honest mutual package — the first body refers to the
+second constant, which only the block-level `VDecl.WF.mutualDef` rule can
+check — and the second body chains into the D0 definition, so unfolding now
+crosses three definition layers before reaching a constructor.
+
+The complete `Params`/`Params.Semantic` instance pair is rebuilt over the
+extended environment by the same transport discipline D0 used over D0a:
+old strong derivations cross instances through an explicit syntax functor,
+while the iota reduction sites are replayed against the extended environment
+itself, never cast back into the smaller one.
+
+The quotient half of the D1 plan line (`CertifiedExtension.quot`) is
+deliberately not instantiated here; the current `CtorBundle.hu0` interface
+obligation is unsatisfiable for `Quot.mk` (a `Prop`-instantiable
+constructor, exactly the punit disqualification recorded in
+`plans/l4l-16d0-slice-map.md`).  See the obstruction record at the end of
+this file.
+-/
+
+namespace Lean4Lean
+namespace SExpr
+namespace ParamsD1
+
+open InductiveFixtures InductiveReplayFixtures VInductDecl
+open ParamsD0
+
+/-! ## D1 declaration layer
+
+Host declarations supply stable kernel names; the Theory payloads are spelled
+out explicitly below. -/
+
+/-- Host anchor for the second mutual definition: one more successor over the
+checked D0 definition. -/
+def d1mutB : Nat := Nat.succ ParamsD0.d0def
+
+/-- Host anchor for the first mutual definition.  Its body is the *other*
+member of the block, so its Theory value can only be checked after both
+constants are added — the `mutualDef` shape. -/
+def d1mutA : Nat := d1mutB
+
+/-- Theory payload for `d1mutA : Nat := d1mutB`.  The value refers to the
+block-mate constant `d1mutB`, which is *not* in scope for a plain `.def`
+history step. -/
+def d1MutAVal : VDefVal where
+  name := ``d1mutA
+  uvars := 0
+  type := .const ``Nat []
+  value := .const ``d1mutB []
+
+/-- Theory payload for `d1mutB : Nat := Nat.succ d0def`. -/
+def d1MutBVal : VDefVal where
+  name := ``d1mutB
+  uvars := 0
+  type := .const ``Nat []
+  value := .app (.const ``Nat.succ []) (.const ``d0def [])
+
+/-- The mutual block, in declaration order. -/
+def d1Muts : List VDefVal := [d1MutAVal, d1MutBVal]
+
+theorem d1MutA_fresh : d0Env.constants d1MutAVal.name = none := by
+  native_decide
+
+theorem d1MutB_fresh : d0Env.constants d1MutBVal.name = none := by
+  native_decide
+
+theorem d1MutA_name_ne_nat : d1MutAVal.name ≠ ``Nat := by native_decide
+theorem d1MutA_name_ne_natZero : d1MutAVal.name ≠ ``Nat.zero := by
+  native_decide
+theorem d1MutA_name_ne_natSucc : d1MutAVal.name ≠ ``Nat.succ := by
+  native_decide
+theorem d1MutA_name_ne_natRec : d1MutAVal.name ≠ ``Nat.rec := by
+  native_decide
+theorem d1MutA_name_ne_d0Def : d1MutAVal.name ≠ d0DefVal.name := by
+  native_decide
+theorem d1MutB_name_ne_nat : d1MutBVal.name ≠ ``Nat := by native_decide
+theorem d1MutB_name_ne_natZero : d1MutBVal.name ≠ ``Nat.zero := by
+  native_decide
+theorem d1MutB_name_ne_natSucc : d1MutBVal.name ≠ ``Nat.succ := by
+  native_decide
+theorem d1MutB_name_ne_natRec : d1MutBVal.name ≠ ``Nat.rec := by
+  native_decide
+theorem d1MutB_name_ne_d0Def : d1MutBVal.name ≠ d0DefVal.name := by
+  native_decide
+theorem d1MutA_name_ne_mutB : d1MutAVal.name ≠ d1MutBVal.name := by
+  native_decide
+
+local instance : Inhabited VEnv := ⟨VEnv.empty⟩
+
+/-- The environment after the block's constants but before its equations. -/
+def d1ConstEnvA :=
+  (d0Env.addConst d1MutAVal.name d1MutAVal.toVConstant).get!
+
+def d1ConstEnv :=
+  (d1ConstEnvA.addConst d1MutBVal.name d1MutBVal.toVConstant).get!
+
+theorem d0Env_add_d1MutA :
+    d0Env.addConst d1MutAVal.name d1MutAVal.toVConstant =
+      some d1ConstEnvA := by
+  simp [VEnv.addConst, d1MutA_fresh, d1ConstEnvA]
+
+theorem d1MutB_fresh_A : d1ConstEnvA.constants d1MutBVal.name = none := by
+  have hne := d1MutA_name_ne_mutB
+  simp [d1ConstEnvA, VEnv.addConst, d1MutA_fresh, hne, d1MutB_fresh]
+
+theorem d1ConstEnvA_add_d1MutB :
+    d1ConstEnvA.addConst d1MutBVal.name d1MutBVal.toVConstant =
+      some d1ConstEnv := by
+  simp [VEnv.addConst, d1MutB_fresh_A, d1ConstEnv]
+
+theorem d0Env_add_d1Muts : d0Env.addConsts d1Muts = some d1ConstEnv := by
+  simp [VEnv.addConsts, d1Muts, List.foldlM, d0Env_add_d1MutA,
+    d1ConstEnvA_add_d1MutB]
+
+/-- The complete D1 environment: the D0 environment followed by one checked
+mutual definition block. -/
+def d1Env : VEnv := d1ConstEnv.addDefEqs d1Muts
+
+theorem d1Env_eq_addDefEq :
+    d1Env = (d1ConstEnv.addDefEq d1MutAVal.toDefEq).addDefEq
+      d1MutBVal.toDefEq := rfl
+
+theorem d0Env_le_d1ConstEnv : d0Env ≤ d1ConstEnv :=
+  (VEnv.addConst_le d0Env_add_d1MutA).trans
+    (VEnv.addConst_le d1ConstEnvA_add_d1MutB)
+
+theorem d0Env_le_d1Env : d0Env ≤ d1Env :=
+  d0Env_le_d1ConstEnv.trans
+    (VEnv.addDefEq_le.trans VEnv.addDefEq_le)
+
+/-- The Nat family head is a type in the D0 environment; both block members
+declare it as their type. -/
+theorem d1NatIsType : d0Env.IsType 0 [] (.const ``Nat []) := by
+  have h := VEnv.HasType.const (U := 0) (Γ := [])
+    (ls := [])
+    (natFinalEnv_le_d0Env.constants
+      InductiveReplayFixtures.nat_type_env_lookup)
+    (by simp) rfl
+  rw [probeNatTypeTypeV_eq] at h
+  exact ⟨_, h⟩
+
+theorem d1Muts_types_wf : ∀ ci ∈ d1Muts, ci.toVConstant.WF d0Env := by
+  intro ci hci
+  simp only [d1Muts, List.mem_cons, List.not_mem_nil, or_false] at hci
+  rcases hci with rfl | rfl
+  · exact d1NatIsType
+  · exact d1NatIsType
+
+theorem d1ConstEnv_d1MutA_lookup :
+    d1ConstEnv.constants d1MutAVal.name =
+      some d1MutAVal.toVConstant :=
+  (VEnv.addConst_le d1ConstEnvA_add_d1MutB).constants
+    (VEnv.addConst_self d0Env_add_d1MutA)
+
+theorem d1ConstEnv_d1MutB_lookup :
+    d1ConstEnv.constants d1MutBVal.name =
+      some d1MutBVal.toVConstant :=
+  VEnv.addConst_self d1ConstEnvA_add_d1MutB
+
+theorem d1ConstEnv_natSucc_lookup :
+    d1ConstEnv.constants ``Nat.succ =
+      some InductiveFixtures.natType.ctors[1].toVConstant :=
+  d0Env_le_d1ConstEnv.constants d0NatSuccEnvLookup
+
+theorem d1ConstEnv_d0Def_lookup :
+    d1ConstEnv.constants d0DefVal.name = some d0DefVal.toVConstant :=
+  d0Env_le_d1ConstEnv.constants d0Env_d0Def_lookup
+
+theorem d1MutAVal_wf : d1MutAVal.WF d1ConstEnv := by
+  have h := VEnv.HasType.const (U := 0) (Γ := []) (ls := [])
+    d1ConstEnv_d1MutB_lookup (by simp) rfl
+  exact h
+
+theorem d1MutBVal_wf : d1MutBVal.WF d1ConstEnv := by
+  have hsucc := VEnv.HasType.const (U := 0) (Γ := []) (ls := [])
+    d1ConstEnv_natSucc_lookup (by simp) rfl
+  rw [probeNatSuccCtorTypeV_eq] at hsucc
+  have hdef := VEnv.HasType.const (U := 0) (Γ := []) (ls := [])
+    d1ConstEnv_d0Def_lookup (by simp) rfl
+  exact VEnv.HasType.app hsucc hdef
+
+theorem d1Muts_values_wf : ∀ ci ∈ d1Muts, ci.WF d1ConstEnv := by
+  intro ci hci
+  simp only [d1Muts, List.mem_cons, List.not_mem_nil, or_false] at hci
+  rcases hci with rfl | rfl
+  · exact d1MutAVal_wf
+  · exact d1MutBVal_wf
+
+theorem d1Env_wf : d1Env.WF := by
+  obtain ⟨ds, hds⟩ := d0Env_wf
+  exact ⟨.mutualDef d1Muts :: ds,
+    .decl (.mutualDef d1Muts_types_wf d0Env_add_d1Muts d1Muts_values_wf)
+      hds⟩
+
+theorem d1Env_ordered : d1Env.Ordered := d1Env_wf.ordered
+
+theorem d1Env_d1MutA_lookup :
+    d1Env.constants d1MutAVal.name = some d1MutAVal.toVConstant :=
+  (VEnv.addDefEq_le.trans VEnv.addDefEq_le).constants
+    d1ConstEnv_d1MutA_lookup
+
+theorem d1Env_d1MutB_lookup :
+    d1Env.constants d1MutBVal.name = some d1MutBVal.toVConstant :=
+  (VEnv.addDefEq_le.trans VEnv.addDefEq_le).constants
+    d1ConstEnv_d1MutB_lookup
+
+theorem d1Env_constants_old {c : Name} {ci : VConstant}
+    (hneA : c ≠ d1MutAVal.name) (hneB : c ≠ d1MutBVal.name)
+    (H : d1Env.constants c = some ci) :
+    d0Env.constants c = some ci := by
+  have hne := d1MutA_name_ne_mutB
+  simpa [d1Env, VEnv.addDefEqs, d1Muts, d1ConstEnv, d1ConstEnvA,
+    VEnv.addConst, d1MutA_fresh, d1MutB_fresh, hne, VEnv.addDefEq,
+    Ne.symm hneA, Ne.symm hneB] using H
+
+theorem d1Env_defeqs_iff (df : VDefEq) :
+    d1Env.defeqs df ↔
+      df = d1MutBVal.toDefEq ∨ df = d1MutAVal.toDefEq ∨
+        d0Env.defeqs df := by
+  have hne := d1MutA_name_ne_mutB
+  simp [d1Env, VEnv.addDefEqs, d1Muts, d1ConstEnv, d1ConstEnvA,
+    VEnv.addConst, d1MutA_fresh, d1MutB_fresh, hne, VEnv.addDefEq]
+
+theorem d1Env_defeq_mutA : d1Env.defeqs d1MutAVal.toDefEq := by
+  rw [d1Env_defeqs_iff]
+  exact .inr (.inl rfl)
+
+theorem d1Env_defeq_mutB : d1Env.defeqs d1MutBVal.toDefEq := by
+  rw [d1Env_defeqs_iff]
+  exact .inl rfl
+
+theorem d1Env_no_structEta (rule : VStructEta) :
+    ¬d1Env.structEtas rule := by
+  change ¬False
+  intro h
+  exact h
+
+/-! ## D1 pattern layer -/
+
+/-- D1 adds the two mutual definition heads to the D0 table. -/
+def d1Classify (n : Name) : Option Classification :=
+  if n = d1MutAVal.name then some (.symb 0)
+  else if n = d1MutBVal.name then some (.symb 0)
+  else d0Classify n
+
+theorem d1MutAClosed : d1MutAVal.value.Closed := by decide
+
+theorem d1MutBClosed : d1MutBVal.value.Closed := by decide
+
+/-- The complete D1 pattern inventory: the D0 inventory (both generated Nat
+iota rules and the `d0def` rule) plus the two mutual definition rules. -/
+inductive D1Pat : (p : Pattern) → p.RHS × p.Check → Prop where
+  | old {p : Pattern} {r : p.RHS × p.Check} : D0Pat p r → D1Pat p r
+  | defnA : D1Pat (.const d1MutAVal.name)
+      (.fixed d1MutAVal.value d1MutAClosed, .true)
+  | defnB : D1Pat (.const d1MutBVal.name)
+      (.fixed d1MutBVal.value d1MutBClosed, .true)
+
+theorem d0Classify_d1MutA_none : d0Classify d1MutAVal.name = none := by
+  native_decide
+
+theorem d0Classify_d1MutB_none : d0Classify d1MutBVal.name = none := by
+  native_decide
+
+theorem d1Pat_simple {p : Pattern} {r : p.RHS × p.Check}
+    (H : D1Pat p r) : ∃ sp : SimplePattern, p = sp.toPattern := by
+  cases H with
+  | old H => exact d0Pat_simple H
+  | defnA => exact ⟨.defn d1MutAVal.name, rfl⟩
+  | defnB => exact ⟨.defn d1MutBVal.name, rfl⟩
+
+theorem d0Classify_agrees {c : Name} {cl : Classification}
+    (H : d0Classify c = some cl) : d1Classify c = some cl := by
+  have hneA : c ≠ d1MutAVal.name := by
+    intro h
+    subst c
+    rw [d0Classify_d1MutA_none] at H
+    cases H
+  have hneB : c ≠ d1MutBVal.name := by
+    intro h
+    subst c
+    rw [d0Classify_d1MutB_none] at H
+    cases H
+  simpa [d1Classify, hneA, hneB] using H
+
+theorem d0PatWF_lift {p : Pattern} {top : Bool} {extra : Nat}
+    (H : p.WF d0Classify top extra) : p.WF d1Classify top extra := by
+  induction p generalizing top extra with
+  | const c =>
+    exact d0Classify_agrees H
+  | var f ih =>
+    exact ih H
+  | app f a ihf iha =>
+    exact ⟨ihf H.1, iha H.2⟩
+
+theorem d1Pat_wf {p : Pattern} {r : p.RHS × p.Check}
+    (H : D1Pat p r) : p.WF d1Classify := by
+  cases H with
+  | old H => exact d0PatWF_lift (d0Pat_wf H)
+  | defnA => simp [Pattern.WF, d1Classify]
+  | defnB =>
+    have hne := d1MutA_name_ne_mutB
+    simp [Pattern.WF, d1Classify, Ne.symm hne]
+
+/-- Neither fresh mutual-definition head intersects any subpattern of a D0
+pattern. -/
+theorem d1Def_inter_d0Subpattern_none {nm : Name}
+    (hrec : nm ≠ ``Nat.rec) (hzero : nm ≠ ``Nat.zero)
+    (hsucc : nm ≠ ``Nat.succ) (hdef : nm ≠ d0DefVal.name)
+    {p p' : Pattern} {r : p.RHS × p.Check} (H : D0Pat p r)
+    (hsub : Subpattern p' p) :
+    (Pattern.const nm).inter p' = none := by
+  cases H with
+  | iota H =>
+    rcases natPat_pattern H with hp | hp
+    · subst p
+      rcases RecursorIotaPattern.subpattern_inv hsub with
+        rfl | ⟨j, -, rfl⟩ | ⟨j, -, rfl⟩
+      · rfl
+      · simpa only [Pattern.varN] using
+          Pattern.varN_const_inter_of_ne_name hrec 0 j
+      · simpa only [Pattern.varN] using
+          Pattern.varN_const_inter_of_ne_name hzero 0 j
+    · subst p
+      rcases RecursorIotaPattern.subpattern_inv hsub with
+        rfl | ⟨j, -, rfl⟩ | ⟨j, -, rfl⟩
+      · rfl
+      · simpa only [Pattern.varN] using
+          Pattern.varN_const_inter_of_ne_name hrec 0 j
+      · simpa only [Pattern.varN] using
+          Pattern.varN_const_inter_of_ne_name hsucc 0 j
+  | defn =>
+    cases hsub
+    simp [Pattern.inter, hdef]
+
+theorem d1MutA_inter_d0_none {p p' : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) (hsub : Subpattern p' p) :
+    (Pattern.const d1MutAVal.name).inter p' = none :=
+  d1Def_inter_d0Subpattern_none d1MutA_name_ne_natRec
+    d1MutA_name_ne_natZero d1MutA_name_ne_natSucc d1MutA_name_ne_d0Def
+    H hsub
+
+theorem d1MutB_inter_d0_none {p p' : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) (hsub : Subpattern p' p) :
+    (Pattern.const d1MutBVal.name).inter p' = none :=
+  d1Def_inter_d0Subpattern_none d1MutB_name_ne_natRec
+    d1MutB_name_ne_natZero d1MutB_name_ne_natSucc d1MutB_name_ne_d0Def
+    H hsub
+
+/-- A D0 pattern head never matches either fresh definition head.  This is
+the mirror image of the lemmas above, needed when the *old* pattern supplies
+the intersection side. -/
+theorem d0_inter_d1MutA_none {p p' : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) (hsub : Subpattern p' (Pattern.const d1MutAVal.name)) :
+    p.inter p' = none := by
+  cases hsub
+  rw [Pattern.inter_comm]
+  exact d1MutA_inter_d0_none H .refl
+
+theorem d0_inter_d1MutB_none {p p' : Pattern} {r : p.RHS × p.Check}
+    (H : D0Pat p r) (hsub : Subpattern p' (Pattern.const d1MutBVal.name)) :
+    p.inter p' = none := by
+  cases hsub
+  rw [Pattern.inter_comm]
+  exact d1MutB_inter_d0_none H .refl
+
+theorem d1Pat_uniq {p₁ p₂ p₃ p₄ : Pattern}
+    {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check}
+    (H1 : D1Pat p₁ r) (H2 : D1Pat p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by
+  cases H1 with
+  | old H1 =>
+    cases H2 with
+    | old H2 => exact d0Pat_uniq H1 H2 H3 H4
+    | defnA =>
+      rw [d1MutA_inter_d0_none H1 H3] at H4
+      cases H4
+    | defnB =>
+      rw [d1MutB_inter_d0_none H1 H3] at H4
+      cases H4
+  | defnA =>
+    cases H2 with
+    | old H2 =>
+      rw [d0_inter_d1MutA_none H2 H3] at H4
+      cases H4
+    | defnA =>
+      cases H3
+      simp [Pattern.inter] at H4
+      subst p₄
+      exact ⟨rfl, rfl, HEq.rfl⟩
+    | defnB =>
+      cases H3
+      have hne := d1MutA_name_ne_mutB
+      simp [Pattern.inter, Ne.symm hne] at H4
+  | defnB =>
+    cases H2 with
+    | old H2 =>
+      rw [d0_inter_d1MutB_none H2 H3] at H4
+      cases H4
+    | defnA =>
+      cases H3
+      have hne := d1MutA_name_ne_mutB
+      simp [Pattern.inter, hne] at H4
+    | defnB =>
+      cases H3
+      simp [Pattern.inter] at H4
+      subst p₄
+      exact ⟨rfl, rfl, HEq.rfl⟩
+
+theorem d1Pat_app_l {p : Pattern} {r : p.RHS × p.Check}
+    {p₁ p₂ p₃ p₄ : Pattern}
+    (H : D1Pat p r) (h : Subpattern (.app p₁ p₂) p) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  cases H with
+  | old H => exact d0Pat_app_l H h
+  | defnA => cases h
+  | defnB => cases h
+
+theorem d1Pat_app_l_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : D1Pat p r) (H' : D1Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases H with
+  | old H =>
+    cases H' with
+    | old H' => exact d0Pat_app_l_uniq H H' h h' h₃
+    | defnA => cases h'
+    | defnB => cases h'
+  | defnA => cases h
+  | defnB => cases h
+
+theorem d1Pat_app_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : D1Pat p r) (H' : D1Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases H with
+  | old H =>
+    cases H' with
+    | old H' => exact d0Pat_app_uniq H H' h h' h₃ h₃'
+    | defnA => cases h'
+    | defnB => cases h'
+  | defnA => cases h
+  | defnB => cases h
+
+/-- The complete D1 structural instance: the D0 inventory extended by the
+checked mutual definition block. -/
+def d1Params (univs : Nat) : Params where
+  env := d1Env
+  henv := d1Env_ordered
+  univs := univs
+  Pat := D1Pat
+  classify := d1Classify
+  pat_simple := d1Pat_simple
+  pat_wf := d1Pat_wf
+  pat_uniq := d1Pat_uniq
+  pat_app_l := d1Pat_app_l
+  pat_app_l_uniq := d1Pat_app_l_uniq
+  pat_app_uniq := d1Pat_app_uniq
+
+/-! ## D0-to-D1 proof transport
+
+`SExpr` retains its complete `Params` value as an inductive parameter, so
+crossing from the D0 instance into the extended D1 instance is an explicit
+syntax map, exactly as in D0's own D0a→D0b transport.  Unlike that template,
+the `const` and `defn` cases are now live: the source inventory already
+contains a definition pattern (`d0def`), which transports along the
+`D1Pat.old` inclusion. -/
+
+def d0ToD1Level (univs : Nat)
+    (u : @SLevel (d0Params univs)) : @SLevel (d1Params univs) := by
+  refine ⟨u.1, ?_⟩
+  obtain ⟨l, hl, heval⟩ := u.2
+  refine ⟨l, ?_, heval⟩
+  change l.WF univs
+  change l.WF univs at hl
+  exact hl
+
+def d1ToD0Level (univs : Nat)
+    (u : @SLevel (d1Params univs)) : @SLevel (d0Params univs) := by
+  refine ⟨u.1, ?_⟩
+  obtain ⟨l, hl, heval⟩ := u.2
+  refine ⟨l, ?_, heval⟩
+  change l.WF univs
+  change l.WF univs at hl
+  exact hl
+
+@[simp] theorem d1ToD0Level_d0ToD1Level (univs : Nat)
+    (u : @SLevel (d0Params univs)) :
+    d1ToD0Level univs (d0ToD1Level univs u) = u := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem d0ToD1Level_d1ToD0Level (univs : Nat)
+    (u : @SLevel (d1Params univs)) :
+    d0ToD1Level univs (d1ToD0Level univs u) = u := by
+  apply Subtype.ext
+  rfl
+
+noncomputable def d0ToD1Expr (univs : Nat) (e : @SExpr (d0Params univs)) :
+    @SExpr (d1Params univs) :=
+  @SExpr.rec (d0Params univs)
+    (motive := fun _ => @SExpr (d1Params univs))
+    (fun i => @SExpr.bvar (d1Params univs) i)
+    (fun u => @SExpr.sort (d1Params univs) (d0ToD1Level univs u))
+    (fun c ls => @SExpr.const (d1Params univs) c
+      (ls.map (d0ToD1Level univs)))
+    (fun _ _ f a => @SExpr.app (d1Params univs) f a)
+    (fun _ _ A body => @SExpr.lam (d1Params univs) A body)
+    (fun _ _ A B => @SExpr.forallE (d1Params univs) A B)
+    e
+
+noncomputable def d1ToD0Expr (univs : Nat) (e : @SExpr (d1Params univs)) :
+    @SExpr (d0Params univs) :=
+  @SExpr.rec (d1Params univs)
+    (motive := fun _ => @SExpr (d0Params univs))
+    (fun i => @SExpr.bvar (d0Params univs) i)
+    (fun u => @SExpr.sort (d0Params univs) (d1ToD0Level univs u))
+    (fun c ls => @SExpr.const (d0Params univs) c
+      (ls.map (d1ToD0Level univs)))
+    (fun _ _ f a => @SExpr.app (d0Params univs) f a)
+    (fun _ _ A body => @SExpr.lam (d0Params univs) A body)
+    (fun _ _ A B => @SExpr.forallE (d0Params univs) A B)
+    e
+
+@[simp] theorem d0ToD1Expr_bvar (univs i) :
+    d0ToD1Expr univs (@SExpr.bvar (d0Params univs) i) =
+      @SExpr.bvar (d1Params univs) i := rfl
+
+@[simp] theorem d0ToD1Expr_sort (univs) (u : @SLevel (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.sort (d0Params univs) u) =
+      @SExpr.sort (d1Params univs) (d0ToD1Level univs u) := rfl
+
+@[simp] theorem d0ToD1Expr_const (univs c)
+    (ls : List (@SLevel (d0Params univs))) :
+    d0ToD1Expr univs (@SExpr.const (d0Params univs) c ls) =
+      @SExpr.const (d1Params univs) c (ls.map (d0ToD1Level univs)) := rfl
+
+@[simp] theorem d0ToD1Expr_app (univs)
+    (f a : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.app (d0Params univs) f a) =
+      @SExpr.app (d1Params univs) (d0ToD1Expr univs f)
+        (d0ToD1Expr univs a) := rfl
+
+@[simp] theorem d0ToD1Expr_lam (univs)
+    (A e : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.lam (d0Params univs) A e) =
+      @SExpr.lam (d1Params univs) (d0ToD1Expr univs A)
+        (d0ToD1Expr univs e) := rfl
+
+@[simp] theorem d0ToD1Expr_forallE (univs)
+    (A B : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.forallE (d0Params univs) A B) =
+      @SExpr.forallE (d1Params univs) (d0ToD1Expr univs A)
+        (d0ToD1Expr univs B) := rfl
+
+@[simp] theorem d1ToD0Expr_bvar (univs i) :
+    d1ToD0Expr univs (@SExpr.bvar (d1Params univs) i) =
+      @SExpr.bvar (d0Params univs) i := rfl
+
+@[simp] theorem d1ToD0Expr_sort (univs) (u : @SLevel (d1Params univs)) :
+    d1ToD0Expr univs (@SExpr.sort (d1Params univs) u) =
+      @SExpr.sort (d0Params univs) (d1ToD0Level univs u) := rfl
+
+@[simp] theorem d1ToD0Expr_const (univs c)
+    (ls : List (@SLevel (d1Params univs))) :
+    d1ToD0Expr univs (@SExpr.const (d1Params univs) c ls) =
+      @SExpr.const (d0Params univs) c (ls.map (d1ToD0Level univs)) := rfl
+
+@[simp] theorem d1ToD0Expr_app (univs)
+    (f a : @SExpr (d1Params univs)) :
+    d1ToD0Expr univs (@SExpr.app (d1Params univs) f a) =
+      @SExpr.app (d0Params univs) (d1ToD0Expr univs f)
+        (d1ToD0Expr univs a) := rfl
+
+@[simp] theorem d1ToD0Expr_lam (univs)
+    (A e : @SExpr (d1Params univs)) :
+    d1ToD0Expr univs (@SExpr.lam (d1Params univs) A e) =
+      @SExpr.lam (d0Params univs) (d1ToD0Expr univs A)
+        (d1ToD0Expr univs e) := rfl
+
+@[simp] theorem d1ToD0Expr_forallE (univs)
+    (A B : @SExpr (d1Params univs)) :
+    d1ToD0Expr univs (@SExpr.forallE (d1Params univs) A B) =
+      @SExpr.forallE (d0Params univs) (d1ToD0Expr univs A)
+        (d1ToD0Expr univs B) := rfl
+
+@[simp] theorem d1ToD0Expr_d0ToD1Expr (univs : Nat)
+    (e : @SExpr (d0Params univs)) :
+    d1ToD0Expr univs (d0ToD1Expr univs e) = e := by
+  induction e <;> simp [List.map_map, Function.comp_def, *]
+
+@[simp] theorem d0ToD1Expr_d1ToD0Expr (univs : Nat)
+    (e : @SExpr (d1Params univs)) :
+    d0ToD1Expr univs (d1ToD0Expr univs e) = e := by
+  induction e <;> simp [List.map_map, Function.comp_def, *]
+
+noncomputable def d0ToD1Subst (univs : Nat)
+    (sigma : @Subst (d0Params univs)) :
+    @Subst (d1Params univs) := fun i => d0ToD1Expr univs (sigma i)
+
+@[simp] theorem d0ToD1Expr_lift' (univs : Nat)
+    (e : @SExpr (d0Params univs)) (rho : Lift) :
+    d0ToD1Expr univs (@SExpr.lift' (d0Params univs) e rho) =
+      @SExpr.lift' (d1Params univs) (d0ToD1Expr univs e) rho := by
+  induction e generalizing rho <;> simp [SExpr.lift', *]
+
+@[simp] theorem d0ToD1Subst_lift (univs : Nat)
+    (sigma : @Subst (d0Params univs)) :
+    d0ToD1Subst univs (@Subst.lift (d0Params univs) sigma) =
+      @Subst.lift (d1Params univs) (d0ToD1Subst univs sigma) := by
+  funext i
+  cases i <;> simp [d0ToD1Subst, Subst.lift,
+    d0ToD1Expr_lift']
+
+@[simp] theorem d0ToD1Expr_subst (univs : Nat)
+    (e : @SExpr (d0Params univs)) (sigma : @Subst (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.subst (d0Params univs) e sigma) =
+      @SExpr.subst (d1Params univs) (d0ToD1Expr univs e)
+        (d0ToD1Subst univs sigma) := by
+  induction e generalizing sigma <;>
+    simp [SExpr.subst, d0ToD1Subst, *]
+
+@[simp] theorem d0ToD1Expr_inst (univs : Nat)
+    (e a : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs (@SExpr.inst (d0Params univs) e a) =
+      @SExpr.inst (d1Params univs) (d0ToD1Expr univs e)
+        (d0ToD1Expr univs a) := by
+  change d0ToD1Expr univs
+      (@SExpr.subst (d0Params univs) e (@Subst.one (d0Params univs) a)) =
+    @SExpr.subst (d1Params univs) (d0ToD1Expr univs e)
+      (@Subst.one (d1Params univs) (d0ToD1Expr univs a))
+  rw [d0ToD1Expr_subst]
+  congr 1
+  funext i
+  cases i <;> rfl
+
+@[simp] theorem d0ToD1Level_instV (univs : Nat)
+    (ls : List (@SLevel (d0Params univs))) (u : VLevel) :
+    d0ToD1Level univs (@SLevel.instV (d0Params univs) ls u) =
+      @SLevel.instV (d1Params univs) (ls.map (d0ToD1Level univs)) u := by
+  apply Subtype.ext
+  funext v
+  change u.eval (ls.map fun l => l.1 v) =
+    u.eval ((ls.map (d0ToD1Level univs)).map fun l => l.1 v)
+  congr 1
+  simp [List.map_map, Function.comp_def, d0ToD1Level]
+
+@[simp] theorem d0ToD1Level_succ (univs : Nat)
+    (u : @SLevel (d0Params univs)) :
+    d0ToD1Level univs (@SLevel.succ (d0Params univs) u) =
+      @SLevel.succ (d1Params univs) (d0ToD1Level univs u) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem d0ToD1Level_imax (univs : Nat)
+    (u v : @SLevel (d0Params univs)) :
+    d0ToD1Level univs (@SLevel.imax (d0Params univs) u v) =
+      @SLevel.imax (d1Params univs)
+        (d0ToD1Level univs u) (d0ToD1Level univs v) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem d0ToD1Expr_mkInst (univs : Nat)
+    (ls : List (@SLevel (d0Params univs))) (e : VExpr) :
+    d0ToD1Expr univs (@SExpr.mkInst (d0Params univs) ls e) =
+      @SExpr.mkInst (d1Params univs) (ls.map (d0ToD1Level univs)) e := by
+  induction e <;> simp [SExpr.mkInst, List.map_map, Function.comp_def, *]
+
+theorem d0Lookup_to_d1 (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))} {i : Nat}
+    {A : @SExpr (d0Params univs)}
+    (H : @Lookup (d0Params univs) Gamma i A) :
+    @Lookup (d1Params univs) (Gamma.map (d0ToD1Expr univs)) i
+      (d0ToD1Expr univs A) := by
+  letI : Params := d1Params univs
+  induction H with
+  | zero =>
+    rw [d0ToD1Expr_lift']
+    exact .zero
+  | succ _ ih =>
+    rw [d0ToD1Expr_lift']
+    exact .succ ih
+
+theorem d0IsDefEq_to_d1 (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {e₁ e₂ A : @SExpr (d0Params univs)}
+    (H : @IsDefEq (d0Params univs) Gamma e₁ e₂ A) :
+    @IsDefEq (d1Params univs) (Gamma.map (d0ToD1Expr univs))
+      (d0ToD1Expr univs e₁) (d0ToD1Expr univs e₂)
+      (d0ToD1Expr univs A) := by
+  letI : Params := d1Params univs
+  induction H with
+  | bvar h => exact .bvar (d0Lookup_to_d1 univs h)
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [d0ToD1Expr_sort, d0ToD1Level_succ] using
+      (IsDefEq.sort : IsDefEq (Gamma.map (d0ToD1Expr univs))
+        (.sort (d0ToD1Level univs l)) (.sort (d0ToD1Level univs l))
+        (.sort (.succ (d0ToD1Level univs l))))
+  | @const c ci Gamma ls hreg hlen =>
+    simpa only [d0ToD1Expr_const, d0ToD1Expr_mkInst] using
+      (IsDefEq.const (Γ := Gamma.map (d0ToD1Expr univs))
+        (ls := ls.map (d0ToD1Level univs))
+        (d0Env_le_d1Env.constants hreg) (by simpa using hlen))
+  | appDF _ _ ihf iha =>
+    rw [d0ToD1Expr_app, d0ToD1Expr_app, d0ToD1Expr_inst]
+    exact IsDefEq.appDF ihf iha
+  | lamDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, d0ToD1Expr_lam, d0ToD1Expr_forallE] using
+      IsDefEq.lamDF ihA ihBody
+  | forallEDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, d0ToD1Expr_forallE, d0ToD1Expr_sort,
+      d0ToD1Level_imax] using IsDefEq.forallEDF ihA ihBody
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ ihBody ihArg =>
+    simpa only [List.map_cons, d0ToD1Expr_app, d0ToD1Expr_lam,
+      d0ToD1Expr_inst] using
+      IsDefEq.beta ihBody ihArg
+  | eta _ ih =>
+    rw [d0ToD1Expr_lam, d0ToD1Expr_app, d0ToD1Expr_bvar,
+      d0ToD1Expr_forallE, d0ToD1Expr_lift']
+    exact IsDefEq.eta ih
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @extra df Gamma ls hreg hlen =>
+    simpa only [d0ToD1Expr_mkInst] using
+      (IsDefEq.extra (Γ := Gamma.map (d0ToD1Expr univs))
+        (ls := ls.map (d0ToD1Level univs))
+        (d0Env_le_d1Env.defeqs hreg) (by simpa using hlen))
+
+/-- A constructor-shaped D1 classification cannot be either fresh definition
+head, and therefore restricts to the same constructor classification in D0.
+-/
+theorem d1CtorToD0 (univs : Nat) {c : Name}
+    (H : @CtorBundle.IsCtor (d1Params univs) c) :
+    @CtorBundle.IsCtor (d0Params univs) c := by
+  change ∃ cl, d1Classify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true at H
+  change ∃ cl, d0Classify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true
+  obtain ⟨cl, hclass, hshape⟩ := H
+  have hneA : c ≠ d1MutAVal.name := by
+    intro hc
+    subst c
+    simp [d1Classify] at hclass
+    subst cl
+    simp at hshape
+  have hneB : c ≠ d1MutBVal.name := by
+    intro hc
+    subst c
+    simp [d1Classify, Ne.symm d1MutA_name_ne_mutB] at hclass
+    subst cl
+    simp at hshape
+  exact ⟨cl, by simpa [d1Classify, hneA, hneB] using hclass, hshape⟩
+
+theorem d0IndTyClassify_to_d1 {c : Name} {arity : Nat}
+    (H : d0Classify c = some (.indTy arity)) :
+    d1Classify c = some (.indTy arity) :=
+  d0Classify_agrees H
+
+theorem d1CtorToD0_cl_eq (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c) :
+    (@CtorBundle.IsCtor.cl (d0Params univs) c (d1CtorToD0 univs cl)).1 =
+      (@CtorBundle.IsCtor.cl (d1Params univs) c cl).1 := by
+  let oldCl := @CtorBundle.IsCtor.cl (d0Params univs) c
+    (d1CtorToD0 univs cl)
+  let newCl := @CtorBundle.IsCtor.cl (d1Params univs) c cl
+  have hnewD0 : d0Classify c = some newCl.1 := by
+    have hnew := newCl.2.1
+    change d1Classify c = some newCl.1 at hnew
+    have hneA : c ≠ d1MutAVal.name := by
+      intro hc
+      subst c
+      simp [d1Classify] at hnew
+      have hs := newCl.2.2
+      rw [← hnew] at hs
+      simp at hs
+    have hneB : c ≠ d1MutBVal.name := by
+      intro hc
+      subst c
+      simp [d1Classify, Ne.symm d1MutA_name_ne_mutB] at hnew
+      have hs := newCl.2.2
+      rw [← hnew] at hs
+      simp at hs
+    simpa [d1Classify, hneA, hneB] using hnew
+  have hold := oldCl.2.1
+  change d0Classify c = some oldCl.1 at hold
+  exact Option.some.inj (hold.symm.trans hnewD0)
+
+/-- Reindex a D0 constructor bundle through the syntax and classifier maps.
+-/
+noncomputable def d0CtorBundleToD1 (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c)
+    (F : @CtorBundle (d0Params univs) c (d1CtorToD0 univs cl)) :
+    @CtorBundle (d1Params univs) c cl := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  refine @CtorBundle.mk (d1Params univs) c cl I
+    (Ts.map (d0ToD1Expr univs)) (args.map (d0ToD1Expr univs))
+    (d0ToD1Level univs u) ?_ ?_ ?_
+  · rw [List.length_map, hlen, d1CtorToD0_cl_eq univs cl]
+  · change d0Classify I = some (.indTy args.length) at hclI
+    letI : Params := d1Params univs
+    change d1Classify I = some (.indTy (args.map (d0ToD1Expr univs)).length)
+    simpa using d0IndTyClassify_to_d1 hclI
+  · intro hzero
+    have hback := congrArg (d1ToD0Level univs) hzero
+    apply hu0
+    apply Subtype.ext
+    exact congrArg Subtype.val hback
+
+theorem d0ToD1Expr_foldr_forallE (univs : Nat)
+    (Ts : List (@SExpr (d0Params univs))) (e : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs
+        (Ts.foldr (fun A B => @SExpr.forallE (d0Params univs) A B) e) =
+      (Ts.map (d0ToD1Expr univs)).foldr
+        (fun A B => @SExpr.forallE (d1Params univs) A B)
+        (d0ToD1Expr univs e) := by
+  induction Ts <;> simp [*]
+
+theorem d0ToD1Expr_foldr_app (univs : Nat)
+    (args : List (@SExpr (d0Params univs)))
+    (e : @SExpr (d0Params univs)) :
+    d0ToD1Expr univs
+        (args.foldr (fun A acc => @SExpr.app (d0Params univs) acc A) e) =
+      (args.map (d0ToD1Expr univs)).foldr
+        (fun A acc => @SExpr.app (d1Params univs) acc A)
+        (d0ToD1Expr univs e) := by
+  induction args <;> simp [*]
+
+@[simp] theorem d0CtorBundleToD1_rhs (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c)
+    (F : @CtorBundle (d0Params univs) c (d1CtorToD0 univs cl))
+    (ls : List (@SLevel (d0Params univs))) :
+    d0ToD1Expr univs (@CtorBundle.rhs (d0Params univs) c
+      (d1CtorToD0 univs cl) F ls) =
+      @CtorBundle.rhs (d1Params univs) c cl
+        (d0CtorBundleToD1 univs cl F)
+        (ls.map (d0ToD1Level univs)) := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  simp [CtorBundle.rhs, d0CtorBundleToD1,
+    d0ToD1Expr_foldr_forallE, d0ToD1Expr_foldr_app]
+
+@[simp] theorem d0CtorBundleToD1_u (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c)
+    (F : @CtorBundle (d0Params univs) c (d1CtorToD0 univs cl)) :
+    @CtorBundle.u (d1Params univs) c cl
+        (d0CtorBundleToD1 univs cl F) =
+      d0ToD1Level univs
+        (@CtorBundle.u (d0Params univs) c (d1CtorToD0 univs cl) F) := by
+  cases F
+  rfl
+
+@[simp] theorem d0ToD1Expr_rhs_applyS (univs : Nat) {p : Pattern}
+    (r : p.RHS) (m₁ : List (@SLevel (d0Params univs)))
+    (m₂ : p.Path → @SExpr (d0Params univs)) :
+    d0ToD1Expr univs
+        (@Pattern.RHS.applyS (d0Params univs) p m₁ m₂ r) =
+      @Pattern.RHS.applyS (d1Params univs) p
+        (m₁.map (d0ToD1Level univs))
+        (fun path => d0ToD1Expr univs (m₂ path)) r := by
+  induction r with
+  | fixed e closed => exact d0ToD1Expr_mkInst univs m₁ e
+  | var path => rfl
+  | app f a ihf iha =>
+    simp only [Pattern.RHS.applyS, d0ToD1Expr_app, ihf, iha]
+
+theorem d0MatchesS_to_d1 (univs : Nat) {p : Pattern}
+    {e : @SExpr (d0Params univs)}
+    {m₁ : List (@SLevel (d0Params univs))}
+    {m₂ : p.Path → @SExpr (d0Params univs)}
+    (H : @Pattern.MatchesS (d0Params univs) p e m₁ m₂) :
+    @Pattern.MatchesS (d1Params univs) p (d0ToD1Expr univs e)
+      (m₁.map (d0ToD1Level univs))
+      (fun path => d0ToD1Expr univs (m₂ path)) := by
+  letI : Params := d1Params univs
+  induction H with
+  | @const c ls =>
+    rw [d0ToD1Expr_const]
+    refine cast ?_ (@Pattern.MatchesS.const (d1Params univs) c
+      (ls.map (d0ToD1Level univs)))
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f₁ g₁ a' _ ih =>
+    change @Pattern.MatchesS (d1Params univs) (.var f)
+      (.app (d0ToD1Expr univs f') (d0ToD1Expr univs a'))
+      (f₁.map (d0ToD1Level univs))
+      (fun path => d0ToD1Expr univs (Option.elim path a' g₁))
+    have heq : (fun path => d0ToD1Expr univs (Option.elim path a' g₁)) =
+        (fun path => Option.elim path (d0ToD1Expr univs a')
+          (fun path => d0ToD1Expr univs (g₁ path))) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f₁ g₁ a a' f₂ g₂ _ _ ihf iha =>
+    change @Pattern.MatchesS (d1Params univs) (.app f a)
+      (@SExpr.app (d1Params univs)
+        (d0ToD1Expr univs f') (d0ToD1Expr univs a'))
+      (f₁.map (d0ToD1Level univs))
+      (fun path => d0ToD1Expr univs (Sum.elim g₁ g₂ path))
+    have heq : (fun path => d0ToD1Expr univs (Sum.elim g₁ g₂ path)) =
+        Sum.elim (fun path => d0ToD1Expr univs (g₁ path))
+          (fun path => d0ToD1Expr univs (g₂ path)) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ihf.app iha
+
+theorem d0ToD1_defeqsS (univs : Nat) {p : Pattern}
+    (ck : p.Check) (m₁ : List (@SLevel (d0Params univs)))
+    (m₂ : p.Path → @SExpr (d0Params univs)) :
+    (@Pattern.Check.defeqsS (d0Params univs) p m₁ m₂ ck).map
+        (fun ab => (d0ToD1Expr univs ab.1, d0ToD1Expr univs ab.2)) =
+      @Pattern.Check.defeqsS (d1Params univs) p
+        (m₁.map (d0ToD1Level univs))
+        (fun path => d0ToD1Expr univs (m₂ path)) ck := by
+  induction ck with
+  | true => rfl
+  | defeq a b rest ih =>
+    simp only [Pattern.Check.defeqsS, List.map_cons, ih,
+      d0ToD1Expr_rhs_applyS]
+
+noncomputable def d0ToD1Dfs (univs : Nat)
+    (dfs : List (@SExpr (d0Params univs) × @SExpr (d0Params univs) ×
+      @SExpr (d0Params univs))) :
+    List (@SExpr (d1Params univs) × @SExpr (d1Params univs) ×
+      @SExpr (d1Params univs)) :=
+  dfs.map fun (B, a, b) =>
+    (d0ToD1Expr univs B, d0ToD1Expr univs a, d0ToD1Expr univs b)
+
+theorem d0ToD1Dfs_map_snd (univs : Nat)
+    (dfs : List (@SExpr (d0Params univs) × @SExpr (d0Params univs) ×
+      @SExpr (d0Params univs))) :
+    (d0ToD1Dfs univs dfs).map (fun x => x.2) =
+      (dfs.map fun x => x.2).map fun ab =>
+        (d0ToD1Expr univs ab.1, d0ToD1Expr univs ab.2) := by
+  simp [d0ToD1Dfs, List.map_map, Function.comp_def]
+
+noncomputable def d0Action_to_d1 (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))} {p : Pattern}
+    {r : p.RHS × p.Check} {e A : @SExpr (d0Params univs)}
+    {m₁ : List (@SLevel (d0Params univs))}
+    {m₂ : p.Path → @SExpr (d0Params univs)}
+    (H : @Pattern.Action (d0Params univs) Gamma p r e m₁ m₂ A) :
+    @Pattern.Action (d1Params univs)
+      (Gamma.map (d0ToD1Expr univs)) p r
+      (d0ToD1Expr univs e) (m₁.map (d0ToD1Level univs))
+      (fun path => d0ToD1Expr univs (m₂ path))
+      (d0ToD1Expr univs A) := by
+  rcases H with ⟨hpat, hmatched, dfs, hdefeqs, hchecked, hsound⟩
+  change D0Pat p r at hpat
+  refine @Pattern.Action.mk (d1Params univs)
+    (Gamma := Gamma.map (d0ToD1Expr univs)) (p := p) (r := r)
+    (e := d0ToD1Expr univs e)
+    (m1 := m₁.map (d0ToD1Level univs))
+    (m2 := fun path => d0ToD1Expr univs (m₂ path))
+    (A := d0ToD1Expr univs A) (.old hpat)
+    (d0MatchesS_to_d1 univs hmatched) (d0ToD1Dfs univs dfs) ?_ ?_ ?_
+  · rw [d0ToD1Dfs_map_snd, hdefeqs]
+    exact d0ToD1_defeqsS univs r.2 m₁ m₂
+  · intro a b B hmem
+    simp only [d0ToD1Dfs, List.mem_map] at hmem
+    obtain ⟨⟨B₀, a₀, b₀⟩, hmem₀, heq⟩ := hmem
+    cases heq
+    exact d0IsDefEq_to_d1 univs (hchecked a₀ b₀ B₀ hmem₀)
+  · simpa only [d0ToD1Expr_rhs_applyS] using
+      d0IsDefEq_to_d1 univs hsound
+
+/-- At a constant already present in the D0 environment, the only D1 pattern
+members are the inherited D0 ones; both fresh definition heads are new
+names. -/
+theorem d1Pat_at_old_const {c : Name} {ci : VConstant}
+    (hreg : d0Env.constants c = some ci)
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : D1Pat (.const c) r) : D0Pat (.const c) r := by
+  cases H with
+  | old H => exact H
+  | defnA =>
+    rw [d1MutA_fresh] at hreg
+    cases hreg
+  | defnB =>
+    rw [d1MutB_fresh] at hreg
+    cases hreg
+
+/-- Transport a D0 evidence-rich derivation into the mutual-definition
+extended D1 syntax and registry.  The `const` and `defn` cases carry the
+inherited `d0def` pattern across the `D1Pat.old` inclusion. -/
+noncomputable def d0StrongToD1 (univs : Nat)
+    {Gamma : List (@SExpr (d0Params univs))}
+    {e₁ e₂ A : @SExpr (d0Params univs)}
+    (H : @IsDefEqStrong (d0Params univs) Gamma e₁ e₂ A) :
+    @IsDefEqStrong (d1Params univs) (Gamma.map (d0ToD1Expr univs))
+      (d0ToD1Expr univs e₁) (d0ToD1Expr univs e₂)
+      (d0ToD1Expr univs A) := by
+  letI : Params := d1Params univs
+  induction H with
+  | bvar h _ ihA => exact .bvar (d0Lookup_to_d1 univs h) ihA
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [d0ToD1Expr_sort, d0ToD1Level_succ] using
+      (IsDefEqStrong.sort : IsDefEqStrong
+        (Gamma.map (d0ToD1Expr univs))
+        (.sort (d0ToD1Level univs l)) (.sort (d0ToD1Level univs l))
+        (.sort (.succ (d0ToD1Level univs l))))
+  | @const c ci Gamma ls u hreg hlen hTy F hF hDef
+      ihTy ihF ihDef =>
+    let F' : ∀ cl : CtorBundle.IsCtor c, CtorBundle c cl := fun cl =>
+      d0CtorBundleToD1 univs cl (F (d1CtorToD0 univs cl))
+    simpa only [d0ToD1Expr_const, d0ToD1Expr_mkInst] using
+      (@IsDefEqStrong.const (d1Params univs) c ci
+      (Gamma.map (d0ToD1Expr univs))
+      (ls.map (d0ToD1Level univs)) (d0ToD1Level univs u)
+      (d0Env_le_d1Env.constants hreg)
+      (by simpa only [List.length_map] using hlen) (by
+        simpa only [d0ToD1Expr_mkInst, d0ToD1Expr_sort] using ihTy)
+      F' (by
+        intro cl
+        dsimp only [F']
+        rw [← d0CtorBundleToD1_rhs, d0CtorBundleToD1_u]
+        have H := ihF (d1CtorToD0 univs cl)
+        simp only [d0ToD1Expr_mkInst, d0ToD1Expr_sort] at H
+        exact H) (by
+        intro r hpat
+        have hold : D0Pat (.const c) r := d1Pat_at_old_const hreg hpat
+        have H := ihDef hold
+        rw [d0ToD1Expr_rhs_applyS] at H
+        have hm2 : (fun path => d0ToD1Expr univs (Empty.elim path)) =
+            (Empty.elim :
+              (Pattern.const c).Path → @SExpr (d1Params univs)) :=
+          funext fun path => nomatch path
+        rw [hm2] at H
+        simpa only [d0ToD1Expr_const, d0ToD1Expr_mkInst] using H))
+  | appDF _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    rw [d0ToD1Expr_inst, d0ToD1Expr_inst, d0ToD1Expr_sort] at ihResult
+    simpa only [List.map_cons, d0ToD1Expr_app, d0ToD1Expr_forallE,
+      d0ToD1Expr_inst] using
+      IsDefEqStrong.appDF ihA ihCod ihf iha ihResult
+  | lamDF _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    simpa only [List.map_cons, d0ToD1Expr_lam, d0ToD1Expr_forallE] using
+      IsDefEqStrong.lamDF ihA ihB ihB' ihBody ihBody'
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    simpa only [List.map_cons, d0ToD1Expr_forallE, d0ToD1Expr_sort,
+      d0ToD1Level_imax] using
+      IsDefEqStrong.forallEDF ihA ihBody ihBody'
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    simp only [d0ToD1Expr_app, d0ToD1Expr_lam,
+      d0ToD1Expr_inst] at ihApp
+    simp only [d0ToD1Expr_inst] at ihInst
+    simpa only [List.map_cons, d0ToD1Expr_app, d0ToD1Expr_lam,
+      d0ToD1Expr_inst] using
+      IsDefEqStrong.beta ihBody ihArg ihApp ihInst
+  | @eta Gamma e A B _ _ ihTerm ihLam =>
+    rw [d0ToD1Expr_lam, d0ToD1Expr_app, d0ToD1Expr_lift',
+      d0ToD1Expr_bvar, d0ToD1Expr_forallE] at ihLam ⊢
+    exact IsDefEqStrong.eta ihTerm ihLam
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @defn c ci Gamma ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    have hm2 : (fun path => d0ToD1Expr univs (Empty.elim path)) =
+        (Empty.elim :
+          (Pattern.const c).Path → @SExpr (d1Params univs)) :=
+      funext fun path => nomatch path
+    let F' : ∀ cl : CtorBundle.IsCtor c, CtorBundle c cl := fun cl =>
+      d0CtorBundleToD1 univs cl (F (d1CtorToD0 univs cl))
+    have action' := d0Action_to_d1 univs action
+    rw [d0ToD1Expr_const, d0ToD1Expr_mkInst, hm2] at action'
+    have hRhs' := ihRhs
+    rw [d0ToD1Expr_rhs_applyS, hm2, d0ToD1Expr_mkInst] at hRhs'
+    have hTy' := ihTy
+    rw [d0ToD1Expr_mkInst, d0ToD1Expr_sort] at hTy'
+    have hF' : ∀ cl, IsDefEqStrong (Gamma.map (d0ToD1Expr univs))
+        (SExpr.mkInst (ls.map (d0ToD1Level univs)) ci.type)
+        ((F' cl).rhs (ls.map (d0ToD1Level univs)))
+        (.sort (F' cl).u) := by
+      intro cl
+      dsimp only [F']
+      rw [← d0CtorBundleToD1_rhs, d0CtorBundleToD1_u]
+      have H := ihF (d1CtorToD0 univs cl)
+      simp only [d0ToD1Expr_mkInst, d0ToD1Expr_sort] at H
+      exact H
+    simpa only [d0ToD1Expr_const, d0ToD1Expr_mkInst,
+      d0ToD1Expr_rhs_applyS, hm2] using
+      IsDefEqStrong.defn (d0Env_le_d1Env.constants hreg)
+        (by simpa only [List.length_map] using hlen)
+        hTy' F' hF' action' hRhs'
+  | extra action _ _ ihLeft ihRight =>
+    rw [d0ToD1Expr_rhs_applyS] at ihRight
+    simpa only [d0ToD1Expr_rhs_applyS] using
+      IsDefEqStrong.extra (d0Action_to_d1 univs action) ihLeft ihRight
+
+@[simp] theorem d1Expr_context_roundtrip (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    (Gamma.map (d1ToD0Expr univs)).map (d0ToD1Expr univs) = Gamma := by
+  simp [List.map_map, Function.comp_def]
+
+@[simp] theorem d1Level_list_roundtrip (univs : Nat)
+    (ls : List (@SLevel (d1Params univs))) :
+    (ls.map (d1ToD0Level univs)).map (d0ToD1Level univs) = ls := by
+  simp [List.map_map, Function.comp_def]
+
+section SemanticCertificates
+
+/-! ## D1 semantic certificates -/
+
+theorem d1StructureEtaSound (univs : Nat) :
+    @Params.StructureEtaSound (d1Params univs) := by
+  letI : Params := d1Params univs
+  intro rule levels Gamma params major hreg
+  exact (d1Env_no_structEta rule hreg).elim
+
+def D1ContextValid (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) : Prop :=
+  letI : Params := d1Params univs
+  OnCtx (Gamma.map SExpr.reify) (d1Env.IsType univs)
+
+def D1TypesDefEq (univs : Nat) {Gamma : List (@SExpr (d1Params univs))}
+    (A B : @SExpr (d1Params univs)) : Prop :=
+  letI : Params := d1Params univs
+  ∃ u, IsDefEq Gamma A B (.sort u)
+
+theorem d1TypeUniq (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {x A B : @SExpr (d1Params univs)}
+    (hGamma : D1ContextValid univs Gamma)
+    (hxA : @IsDefEq (d1Params univs) Gamma x x A)
+    (hxB : @IsDefEq (d1Params univs) Gamma x x B) :
+    D1TypesDefEq (Gamma := Gamma) univs A B := by
+  letI : Params := d1Params univs
+  change OnCtx (Gamma.map SExpr.reify) (d1Env.IsType univs) at hGamma
+  change ∃ u, IsDefEq Gamma A B (.sort u)
+  have hxA' := hxA.reify hGamma
+  have hxB' := hxB.reify hGamma
+  obtain ⟨u, hAB⟩ := hxA'.uniq d1Env_wf hGamma hxB'
+  have hlevels := (VEnv.CtxStrong.strong d1Env_ordered hGamma).levelWF
+  have hAB' := SExpr.IsDefEq.mkS (d1StructureEtaSound univs) hAB hlevels
+  have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  rw [hctx] at hAB'
+  refine ⟨SLevel.mk u, ?_⟩
+  simpa only [SExpr.mk_reify, SExpr.mk] using hAB'
+
+theorem d1TypesTrans (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {A B C : @SExpr (d1Params univs)}
+    (hGamma : D1ContextValid univs Gamma)
+    (hAB : D1TypesDefEq (Gamma := Gamma) univs A B)
+    (hBC : D1TypesDefEq (Gamma := Gamma) univs B C) :
+    D1TypesDefEq (Gamma := Gamma) univs A C := by
+  letI : Params := d1Params univs
+  obtain ⟨u, hAB⟩ := hAB
+  obtain ⟨v, hBC⟩ := hBC
+  obtain ⟨w, huv⟩ := d1TypeUniq univs hGamma hAB.hasType.2 hBC.hasType.1
+  exact ⟨u, hAB.trans (huv.symm.defeqDF hBC)⟩
+
+theorem d1TypesInst (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {D B B' e : @SExpr (d1Params univs)}
+    (hBB' : D1TypesDefEq (Gamma := D :: Gamma) univs B B')
+    (he : @IsDefEq (d1Params univs) Gamma e e D) :
+    D1TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (d1Params univs) B e)
+      (@SExpr.inst (d1Params univs) B' e) := by
+  letI : Params := d1Params univs
+  obtain ⟨u, hBB'⟩ := hBB'
+  have hsubst := hBB'.subst
+    (Ctx.Subst.one IsDefEq.weak' IsDefEq.bvar he)
+  change IsDefEq Gamma (B.inst e) (B'.inst e) (.sort u) at hsubst
+  exact ⟨u, hsubst⟩
+
+theorem d1ForallEInv (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {A B A' B' : @SExpr (d1Params univs)}
+    (hGamma : D1ContextValid univs Gamma)
+    (hPi : D1TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d1Params univs) A B)
+      (@SExpr.forallE (d1Params univs) A' B')) :
+    D1TypesDefEq (Gamma := Gamma) univs A A' ∧
+      D1TypesDefEq (Gamma := A :: Gamma) univs B B' := by
+  letI : Params := d1Params univs
+  change OnCtx (Gamma.map SExpr.reify) (d1Env.IsType univs) at hGamma
+  obtain ⟨_, hPi⟩ := hPi
+  have hPi' := hPi.reify hGamma
+  have hPiU : d1Env.IsDefEqU univs (Gamma.map SExpr.reify)
+      (.forallE A.reify B.reify) (.forallE A'.reify B'.reify) :=
+    ⟨_, hPi'⟩
+  obtain ⟨⟨u, hA⟩, v, hB⟩ :=
+    hPiU.forallE_inv d1Env_wf hGamma
+  have hlevels := (VEnv.CtxStrong.strong d1Env_ordered hGamma).levelWF
+  have hA' := SExpr.IsDefEq.mkS (d1StructureEtaSound univs) hA hlevels
+  have hActx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+    rw [List.map_map]
+    exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+  rw [hActx] at hA'
+  have hAwf : (A.reify).LevelWF univs := SExpr.reify_levelWF A
+  have hB' := SExpr.IsDefEq.mkS (d1StructureEtaSound univs) hB
+    ⟨hlevels, hAwf⟩
+  have hBctx : ((A.reify :: Gamma.map SExpr.reify).map SExpr.mk) =
+      A :: Gamma := by
+    rw [List.map_cons, hActx, SExpr.mk_reify]
+  rw [hBctx] at hB'
+  constructor
+  · refine ⟨SLevel.mk u, ?_⟩
+    simpa only [SExpr.mk_reify, SExpr.mk] using hA'
+  · refine ⟨SLevel.mk v, ?_⟩
+    simpa only [SExpr.mk_reify, SExpr.mk] using hB'
+
+structure D1SpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    (D B e : @SExpr (d1Params univs))
+    (es : List (@SExpr (d1Params univs)))
+    (R : @SExpr (d1Params univs)) where
+  domain : @SExpr (d1Params univs)
+  codomain : @SExpr (d1Params univs)
+  domainEq : D1TypesDefEq (Gamma := Gamma) univs D domain
+  codomainEq : D1TypesDefEq (Gamma := D :: Gamma) univs B codomain
+  argument : @IsDefEq (d1Params univs) Gamma e e domain
+  tail : @SpineWF (d1Params univs) Gamma
+    (@SExpr.inst (d1Params univs) codomain e) es R
+
+theorem d1SpineConsView_nonempty (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {D B Head e R : @SExpr (d1Params univs)}
+    {es : List (@SExpr (d1Params univs))}
+    (hGamma : D1ContextValid univs Gamma)
+    (hHead : D1TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d1Params univs) D B) Head)
+    (H : @SpineWF (d1Params univs) Gamma Head (e :: es) R) :
+    Nonempty (D1SpineConsView (Gamma := Gamma) univs D B e es R) := by
+  letI : Params := d1Params univs
+  generalize hargsEq : e :: es = args at H
+  induction H generalizing D B e es with
+  | nil => cases hargsEq
+  | @cons _ domain _ _ codomain harg htail ih =>
+    cases hargsEq
+    obtain ⟨hdom, hbody⟩ := d1ForallEInv univs hGamma hHead
+    exact ⟨{
+      domain := domain
+      codomain := codomain
+      domainEq := hdom
+      codomainEq := hbody
+      argument := harg
+      tail := htail }⟩
+  | @conv _ Head' u _ _ hconv htail ih =>
+    exact ih (d1TypesTrans univs hGamma hHead ⟨u, hconv⟩) hargsEq
+  | @ret _ _ R' _ _ htail hret ih =>
+    let ⟨view⟩ := ih hHead hargsEq
+    exact ⟨{ view with tail := .ret view.tail hret }⟩
+
+noncomputable def d1SpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {D B Head e R : @SExpr (d1Params univs)}
+    {es : List (@SExpr (d1Params univs))}
+    (hGamma : D1ContextValid univs Gamma)
+    (hHead : D1TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d1Params univs) D B) Head)
+    (H : @SpineWF (d1Params univs) Gamma Head (e :: es) R) :
+    D1SpineConsView (Gamma := Gamma) univs D B e es R :=
+  Classical.choice (d1SpineConsView_nonempty univs hGamma hHead H)
+
+theorem D1SpineConsView.argumentExpected (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {D B e R : @SExpr (d1Params univs)}
+    {es : List (@SExpr (d1Params univs))}
+    (view : D1SpineConsView (Gamma := Gamma) univs D B e es R) :
+    @IsDefEq (d1Params univs) Gamma e e D := by
+  letI : Params := d1Params univs
+  obtain ⟨_, hdom⟩ := view.domainEq
+  exact hdom.symm.defeqDF view.argument
+
+theorem D1SpineConsView.restEq (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {D B e R : @SExpr (d1Params univs)}
+    {es : List (@SExpr (d1Params univs))}
+    (view : D1SpineConsView (Gamma := Gamma) univs D B e es R) :
+    D1TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (d1Params univs) B e)
+      (@SExpr.inst (d1Params univs) view.codomain e) :=
+  d1TypesInst univs view.codomainEq (view.argumentExpected univs)
+
+theorem d1PathSpineOfSpineWF (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {alpha : Type}
+    {value type : alpha → @SExpr (d1Params univs)}
+    {A B : @SExpr (d1Params univs)} {paths : List alpha}
+    (hGamma : D1ContextValid univs Gamma)
+    (htyped : ∀ path, @IsDefEq (d1Params univs) Gamma
+      (value path) (value path) (type path))
+    (H : @SpineWF (d1Params univs) Gamma A (paths.map value) B) :
+    @PathSpineWF (d1Params univs) Gamma alpha value type A paths B := by
+  letI : Params := d1Params univs
+  generalize hargs : paths.map value = args at H
+  induction H generalizing paths with
+  | nil =>
+    have hpaths : paths = [] := by simpa using hargs
+    subst paths
+    exact .nil
+  | @cons e domain es result codomain harg htail ih =>
+    cases paths with
+    | nil => simp at hargs
+    | cons path paths =>
+      simp only [List.map_cons, List.cons.injEq] at hargs
+      obtain ⟨hvalue, hrest⟩ := hargs
+      subst e
+      obtain ⟨_, hdomain⟩ :=
+        d1TypeUniq univs hGamma (htyped path) harg
+      exact .cons hdomain (ih hrest)
+  | @conv Head Head' u es result hHead htail ih =>
+    exact .conv hHead (ih hargs)
+  | @ret Head es result result' u htail hresult ih =>
+    exact .ret (ih hargs) hresult
+
+theorem d1ZeroCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (d1Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d1Params univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0).Path →
+      @SExpr (d1Params univs)}
+    (H : @Pattern.MatchesS (d1Params univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.zero 0)
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ``Nat.zero ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs = [] ∧
+      (natCapturePaths NatGeneration.flatCtors[0]).map mcap =
+        recArgs.reverse := by
+  letI : Params := d1Params univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, -⟩ := matchesS_varN_foldr hctor
+    have hctorArgs : ctorArgs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorArgs
+    refine ⟨hrecLen, rfl, ?_⟩
+    rw [natZeroCapturePaths]
+    change
+      ((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl).map
+          (Sum.elim recCap ctorCap) = recArgs.reverse
+    simpa [List.map_map, Function.comp_def] using hrecValues
+
+theorem d1SuccCaptureValues (univs : Nat)
+    {recLs ctorLs : List (@SLevel (d1Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d1Params univs))}
+    {mcap : (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1).Path →
+      @SExpr (d1Params univs)}
+    (H : @Pattern.MatchesS (d1Params univs)
+      (RecursorIotaPattern ``Nat.rec 3 ``Nat.succ 1)
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr
+          (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ``Nat.rec recLs))
+        (ctorArgs.foldr
+          (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ``Nat.succ ctorLs))) recLs mcap) :
+    recArgs.length = 3 ∧ ctorArgs.length = 1 ∧
+      (natCapturePaths NatGeneration.flatCtors[1]).map mcap =
+        recArgs.reverse ++ ctorArgs.reverse := by
+  letI : Params := d1Params univs
+  cases H with
+  | @app fPat recHead recLevels recCap ctorPat ctorHead ctorLevels ctorCap
+      hrec hctor =>
+    obtain ⟨-, hrecLen, hrecValues⟩ := matchesS_varN_foldr hrec
+    obtain ⟨-, hctorLen, hctorValues⟩ := matchesS_varN_foldr hctor
+    refine ⟨hrecLen, hctorLen, ?_⟩
+    rw [natSuccCapturePaths]
+    change
+      (((Pattern.varNPaths (.const ``Nat.rec) 3).map Sum.inl ++
+          (Pattern.varNPaths (.const ``Nat.succ) 1).map Sum.inr).map
+        (Sum.elim recCap ctorCap)) = recArgs.reverse ++ ctorArgs.reverse
+    simpa [List.map_append, List.map_map, Function.comp_def,
+      hrecValues, hctorValues]
+
+def d1ProbeNatZeroRuleType (univs : Nat)
+    (level : @SLevel (d1Params univs)) : @SExpr (d1Params univs) :=
+  letI : Params := d1Params univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        ((SExpr.bvar 2).app (SExpr.const ``Nat.zero []))))
+
+theorem d1ProbeNatZeroRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (d1Params univs)) :
+    @SExpr.mkInst (d1Params univs) [level]
+        (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type =
+      d1ProbeNatZeroRuleType univs level := by
+  rw [probeNatZeroRuleTypeV_eq]
+  rfl
+
+def d1ProbeNatSuccRuleType (univs : Nat)
+    (level : @SLevel (d1Params univs)) : @SExpr (d1Params univs) :=
+  letI : Params := d1Params univs
+  SExpr.forallE
+    (SExpr.forallE (SExpr.const ``Nat []) (SExpr.sort level))
+    (SExpr.forallE
+      ((SExpr.bvar 0).app (SExpr.const ``Nat.zero []))
+      (SExpr.forallE
+        (SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1)))))
+        (SExpr.forallE (SExpr.const ``Nat [])
+          ((SExpr.bvar 3).app
+            ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))))))
+
+theorem d1ProbeNatSuccRuleTypeS_eq (univs : Nat)
+    (level : @SLevel (d1Params univs)) :
+    @SExpr.mkInst (d1Params univs) [level]
+        (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type =
+      d1ProbeNatSuccRuleType univs level := by
+  rw [probeNatSuccRuleTypeV_eq]
+  rfl
+
+theorem d1IotaRule_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d1Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    Nonempty (@Pattern.IotaRule (d1Params univs)
+      rec major ctor arity r) := by
+  letI : Params := d1Params univs
+  change D1Pat _ _ at H
+  cases H with
+  | old H =>
+    let oldRule := d0IotaRule univs H
+    rcases oldRule with
+      ⟨oldPat, df, registered, rhsClosed, capturePaths, rhsTower⟩
+    exact ⟨{
+      pat := D1Pat.old (by exact oldPat)
+      df := df
+      registered := d0Env_le_d1Env.defeqs registered
+      rhsClosed := rhsClosed
+      capturePaths := capturePaths
+      rhsTower := rhsTower }⟩
+
+noncomputable def d1IotaRule (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d1Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    @Pattern.IotaRule (d1Params univs) rec major ctor arity r :=
+  Classical.choice (d1IotaRule_nonempty univs H)
+
+theorem d1NatRecEnvLookup :
+    d1Env.constants ``Nat.rec =
+      some (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType) :=
+  d0Env_le_d1Env.constants d0NatRecEnvLookup
+
+theorem d1NatZeroEnvLookup :
+    d1Env.constants ``Nat.zero =
+      some InductiveFixtures.natType.ctors[0].toVConstant :=
+  d0Env_le_d1Env.constants d0NatZeroEnvLookup
+
+theorem d1NatSuccEnvLookup :
+    d1Env.constants ``Nat.succ =
+      some InductiveFixtures.natType.ctors[1].toVConstant :=
+  d0Env_le_d1Env.constants d0NatSuccEnvLookup
+
+theorem natRule_rhs_ne_d1MutA {i : Nat}
+    {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    (NatGeneration.rule i constructor).rhs ≠ d1MutAVal.toDefEq.rhs := by
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, _⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl
+  · have hc := Option.some.inj
+      (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+  · have hc := Option.some.inj
+      (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+
+theorem natRule_rhs_ne_d1MutB {i : Nat}
+    {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    (NatGeneration.rule i constructor).rhs ≠ d1MutBVal.toDefEq.rhs := by
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, _⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl
+  · have hc := Option.some.inj
+      (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+  · have hc := Option.some.inj
+      (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    subst constructor
+    native_decide
+
+theorem d1MutA_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (d1Params univs) d1MutAVal.name) : False := by
+  letI : Params := d1Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hc := cl.cl.2.1
+  change d1Classify d1MutAVal.name = some cl.cl.1 at hc
+  have hcl : cl.cl.1 = .symb 0 := by
+    simpa [d1Classify] using hc.symm
+  rw [hcl] at hshape
+  simp [ctorLike] at hshape
+
+theorem d1MutB_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (d1Params univs) d1MutBVal.name) : False := by
+  letI : Params := d1Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hc := cl.cl.2.1
+  change d1Classify d1MutBVal.name = some cl.cl.1 at hc
+  have hne := d1MutA_name_ne_mutB
+  have hcl : cl.cl.1 = .symb 0 := by
+    simpa [d1Classify, Ne.symm hne] using hc.symm
+  rw [hcl] at hshape
+  simp [ctorLike] at hshape
+
+theorem d1Ctor_name_ne_mutA (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c) :
+    c ≠ d1MutAVal.name := by
+  intro hc
+  subst c
+  exact d1MutA_not_ctor univs cl
+
+theorem d1Ctor_name_ne_mutB (univs : Nat) {c : Name}
+    (cl : @CtorBundle.IsCtor (d1Params univs) c) :
+    c ≠ d1MutBVal.name := by
+  intro hc
+  subst c
+  exact d1MutB_not_ctor univs cl
+
+theorem d1NatTypeStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) ``Nat [])
+      (@SExpr.const (d1Params univs) ``Nat [])
+      (@SExpr.sort (d1Params univs)
+        (@SLevel.succ (d1Params univs) (@SLevel.zero (d1Params univs)))) := by
+  have H := d0StrongToD1 univs
+    (d0NatTypeStrong univs (Gamma.map (d1ToD0Expr univs)))
+  simp only [d1Expr_context_roundtrip, d0ToD1Expr_const,
+    d0ToD1Expr_sort, List.map_nil] at H
+  change @IsDefEqStrong (d1Params univs) Gamma
+    (@SExpr.const (d1Params univs) ``Nat [])
+    (@SExpr.const (d1Params univs) ``Nat [])
+    (@SExpr.sort (d1Params univs)
+      (@SLevel.succ (d1Params univs) (@SLevel.zero (d1Params univs)))) at H
+  exact H
+
+theorem d1NatZeroStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) ``Nat.zero [])
+      (@SExpr.const (d1Params univs) ``Nat.zero [])
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  have H := d0StrongToD1 univs
+    (d0NatZeroStrong univs (Gamma.map (d1ToD0Expr univs)))
+  simpa only [d1Expr_context_roundtrip, d0ToD1Expr_const,
+    List.map_nil] using H
+
+theorem d1NatSuccStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) ``Nat.succ [])
+      (@SExpr.const (d1Params univs) ``Nat.succ [])
+      (@SExpr.forallE (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat [])
+        (@SExpr.const (d1Params univs) ``Nat [])) := by
+  have H0 := natStrongToD0 univs
+    (natSuccStrong univs
+      ((Gamma.map (d1ToD0Expr univs)).map (d0ToNatExpr univs)))
+  simp only [d0Expr_context_roundtrip, natToD0Expr_const,
+    natToD0Expr_forallE, List.map_nil] at H0
+  have H := d0StrongToD1 univs H0
+  simpa only [d1Expr_context_roundtrip, d0ToD1Expr_const,
+    d0ToD1Expr_forallE, List.map_nil] using H
+
+theorem d1D0DefStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d0DefVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat.zero [])
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  have H := d0StrongToD1 univs
+    (d0DefStrong univs (Gamma.map (d1ToD0Expr univs)))
+  simpa only [d1Expr_context_roundtrip, d0ToD1Expr_const,
+    List.map_nil] using H
+
+theorem d1D0DefConstStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d0DefVal.name [])
+      (@SExpr.const (d1Params univs) d0DefVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  letI : Params := d1Params univs
+  exact (d1D0DefStrong univs Gamma).trans (d1D0DefStrong univs Gamma).symm
+
+theorem d1MutBRhsStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.app (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat.succ [])
+        (@SExpr.const (d1Params univs) d0DefVal.name []))
+      (@SExpr.app (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat.succ [])
+        (@SExpr.const (d1Params univs) d0DefVal.name []))
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  letI : Params := d1Params univs
+  exact IsDefEqStrong.appDF
+    (d1NatTypeStrong univs Gamma)
+    (d1NatTypeStrong univs (.const ``Nat [] :: Gamma))
+    (d1NatSuccStrong univs Gamma)
+    (d1D0DefConstStrong univs Gamma)
+    (d1NatTypeStrong univs Gamma)
+
+theorem d1MutBDefStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.app (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat.succ [])
+        (@SExpr.const (d1Params univs) d0DefVal.name []))
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  letI : Params := d1Params univs
+  let r : (Pattern.const d1MutBVal.name).RHS ×
+      (Pattern.const d1MutBVal.name).Check :=
+    (.fixed d1MutBVal.value d1MutBClosed, .true)
+  let action : Pattern.Action Gamma r (.const d1MutBVal.name []) []
+      Empty.elim (.const ``Nat []) := {
+    pat := D1Pat.defnB
+    matched := by
+      refine cast ?_ (@Pattern.MatchesS.const (d1Params univs)
+        d1MutBVal.name [])
+      congr 1
+      funext path
+      exact Empty.elim path
+    dfs := []
+    defeqs := rfl
+    checked := by simp
+    sound := by
+      have H := @IsDefEq.extra (d1Params univs) d1MutBVal.toDefEq Gamma []
+        d1Env_defeq_mutB rfl
+      change IsDefEq Gamma (.const d1MutBVal.name [])
+        (.app (.const ``Nat.succ []) (.const d0DefVal.name []))
+        (.const ``Nat []) at H
+      exact H }
+  let F : ∀ cl : CtorBundle.IsCtor d1MutBVal.name,
+      CtorBundle d1MutBVal.name cl := fun cl =>
+    (d1MutB_not_ctor univs cl).elim
+  refine @IsDefEqStrong.defn (d1Params univs) d1MutBVal.name
+    d1MutBVal.toVConstant Gamma []
+    (@SLevel.succ (d1Params univs) (@SLevel.zero (d1Params univs))) r
+    d1Env_d1MutB_lookup rfl ?_ F ?_ action ?_
+  · change IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+      (.sort (.succ .zero))
+    exact d1NatTypeStrong univs Gamma
+  · intro cl
+    exact (d1MutB_not_ctor univs cl).elim
+  · change IsDefEqStrong Gamma
+      (.app (.const ``Nat.succ []) (.const d0DefVal.name []))
+      (.app (.const ``Nat.succ []) (.const d0DefVal.name []))
+      (.const ``Nat [])
+    exact d1MutBRhsStrong univs Gamma
+
+theorem d1MutBConstStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  letI : Params := d1Params univs
+  exact (d1MutBDefStrong univs Gamma).trans (d1MutBDefStrong univs Gamma).symm
+
+theorem d1MutADefStrong (univs : Nat)
+    (Gamma : List (@SExpr (d1Params univs))) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutAVal.name [])
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat []) := by
+  letI : Params := d1Params univs
+  let r : (Pattern.const d1MutAVal.name).RHS ×
+      (Pattern.const d1MutAVal.name).Check :=
+    (.fixed d1MutAVal.value d1MutAClosed, .true)
+  let action : Pattern.Action Gamma r (.const d1MutAVal.name []) []
+      Empty.elim (.const ``Nat []) := {
+    pat := D1Pat.defnA
+    matched := by
+      refine cast ?_ (@Pattern.MatchesS.const (d1Params univs)
+        d1MutAVal.name [])
+      congr 1
+      funext path
+      exact Empty.elim path
+    dfs := []
+    defeqs := rfl
+    checked := by simp
+    sound := by
+      have H := @IsDefEq.extra (d1Params univs) d1MutAVal.toDefEq Gamma []
+        d1Env_defeq_mutA rfl
+      change IsDefEq Gamma (.const d1MutAVal.name [])
+        (.const d1MutBVal.name [])
+        (.const ``Nat []) at H
+      exact H }
+  let F : ∀ cl : CtorBundle.IsCtor d1MutAVal.name,
+      CtorBundle d1MutAVal.name cl := fun cl =>
+    (d1MutA_not_ctor univs cl).elim
+  refine @IsDefEqStrong.defn (d1Params univs) d1MutAVal.name
+    d1MutAVal.toVConstant Gamma []
+    (@SLevel.succ (d1Params univs) (@SLevel.zero (d1Params univs))) r
+    d1Env_d1MutA_lookup rfl ?_ F ?_ action ?_
+  · change IsDefEqStrong Gamma (.const ``Nat []) (.const ``Nat [])
+      (.sort (.succ .zero))
+    exact d1NatTypeStrong univs Gamma
+  · intro cl
+    exact (d1MutA_not_ctor univs cl).elim
+  · change IsDefEqStrong Gamma
+      (.const d1MutBVal.name []) (.const d1MutBVal.name [])
+      (.const ``Nat [])
+    exact d1MutBConstStrong univs Gamma
+
+/-- `Params.Semantic.defn` for the extended inventory: the inherited
+`d0def` rule plus the two mutual definitions.  The mutual chain unfolds
+`d1mutA ↦ d1mutB` (its block-mate) and `d1mutB ↦ Nat.succ d0def`. -/
+theorem d1Defn (univs : Nat) {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : (d1Params univs).Pat (.const c) r) :
+    ∃ (value : VExpr) (closed : value.Closed),
+      r = (.fixed value closed, .true) ∧
+      ∀ {ci : VConstant} {ls : List (@SLevel (d1Params univs))}
+        {Gamma : List (@SExpr (d1Params univs))},
+        d1Env.constants c = some ci → ls.length = ci.uvars →
+        @IsDefEqStrong (d1Params univs) Gamma
+          (@SExpr.const (d1Params univs) c ls)
+          (@SExpr.mkInst (d1Params univs) ls value)
+          (@SExpr.mkInst (d1Params univs) ls ci.type) := by
+  letI : Params := d1Params univs
+  change D1Pat (.const c) r at H
+  cases H with
+  | old H =>
+    cases H with
+    | iota H => exact (natPat_no_const univs H).elim
+    | defn =>
+      refine ⟨d0DefVal.value, d0DefClosed, rfl, ?_⟩
+      intro ci ls Gamma hci hlen
+      have hlook : d1Env.constants d0DefVal.name =
+          some d0DefVal.toVConstant :=
+        d0Env_le_d1Env.constants d0Env_d0Def_lookup
+      have hci' : ci = d0DefVal.toVConstant :=
+        Option.some.inj (hci.symm.trans hlook)
+      subst ci
+      have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+      subst ls
+      change @IsDefEqStrong (d1Params univs) Gamma
+        (@SExpr.const (d1Params univs) d0DefVal.name [])
+        (@SExpr.const (d1Params univs) ``Nat.zero [])
+        (@SExpr.const (d1Params univs) ``Nat [])
+      exact d1D0DefStrong univs Gamma
+  | defnA =>
+    refine ⟨d1MutAVal.value, d1MutAClosed, rfl, ?_⟩
+    intro ci ls Gamma hci hlen
+    have hci' : ci = d1MutAVal.toVConstant :=
+      Option.some.inj (hci.symm.trans d1Env_d1MutA_lookup)
+    subst ci
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutAVal.name [])
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat [])
+    exact d1MutADefStrong univs Gamma
+  | defnB =>
+    refine ⟨d1MutBVal.value, d1MutBClosed, rfl, ?_⟩
+    intro ci ls Gamma hci hlen
+    have hci' : ci = d1MutBVal.toVConstant :=
+      Option.some.inj (hci.symm.trans d1Env_d1MutB_lookup)
+    subst ci
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.app (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat.succ [])
+        (@SExpr.const (d1Params univs) d0DefVal.name []))
+      (@SExpr.const (d1Params univs) ``Nat [])
+    exact d1MutBDefStrong univs Gamma
+
+theorem d1Registered (univs : Nat)
+    {df : VDefEq} {ls : List (@SLevel (d1Params univs))}
+    {Gamma : List (@SExpr (d1Params univs))}
+    (hreg : d1Env.defeqs df) (hlen : ls.length = df.uvars)
+    (_hLhs : @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.mkInst (d1Params univs) ls df.lhs)
+      (@SExpr.mkInst (d1Params univs) ls df.lhs)
+      (@SExpr.mkInst (d1Params univs) ls df.type))
+    (_hRhs : @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.mkInst (d1Params univs) ls df.rhs)
+      (@SExpr.mkInst (d1Params univs) ls df.rhs)
+      (@SExpr.mkInst (d1Params univs) ls df.type)) :
+    @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.mkInst (d1Params univs) ls df.lhs)
+      (@SExpr.mkInst (d1Params univs) ls df.rhs)
+      (@SExpr.mkInst (d1Params univs) ls df.type) := by
+  rw [d1Env_defeqs_iff] at hreg
+  rcases hreg with hB | hA | hold
+  · subst df
+    change ls.length = 0 at hlen
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.app (d1Params univs)
+        (@SExpr.const (d1Params univs) ``Nat.succ [])
+        (@SExpr.const (d1Params univs) d0DefVal.name []))
+      (@SExpr.const (d1Params univs) ``Nat [])
+    exact d1MutBDefStrong univs Gamma
+  · subst df
+    change ls.length = 0 at hlen
+    have hls : ls = [] := List.length_eq_zero_iff.mp hlen
+    subst ls
+    change @IsDefEqStrong (d1Params univs) Gamma
+      (@SExpr.const (d1Params univs) d1MutAVal.name [])
+      (@SExpr.const (d1Params univs) d1MutBVal.name [])
+      (@SExpr.const (d1Params univs) ``Nat [])
+    exact d1MutADefStrong univs Gamma
+  · let oldGamma := Gamma.map (d1ToD0Expr univs)
+    let oldLs := ls.map (d1ToD0Level univs)
+    have oldLen : oldLs.length = df.uvars := by
+      simpa [oldLs] using hlen
+    have oldLhs : @IsDefEqStrong (d0Params univs) oldGamma
+        (@SExpr.mkInst (d0Params univs) oldLs df.lhs)
+        (@SExpr.mkInst (d0Params univs) oldLs df.lhs)
+        (@SExpr.mkInst (d0Params univs) oldLs df.type) := by
+      letI : Params := d0Params univs
+      letI : Params.Semantic := d0Semantic univs
+      exact Params.Semantic.closedHasTypeStrong
+        (d0Env_ordered.defEqWF hold).1
+    have oldRhs : @IsDefEqStrong (d0Params univs) oldGamma
+        (@SExpr.mkInst (d0Params univs) oldLs df.rhs)
+        (@SExpr.mkInst (d0Params univs) oldLs df.rhs)
+        (@SExpr.mkInst (d0Params univs) oldLs df.type) := by
+      letI : Params := d0Params univs
+      letI : Params.Semantic := d0Semantic univs
+      exact Params.Semantic.closedHasTypeStrong
+        (d0Env_ordered.defEqWF hold).2
+    have oldEq := d0Registered univs hold oldLen oldLhs oldRhs
+    have H := d0StrongToD1 univs oldEq
+    dsimp only [oldGamma, oldLs] at H
+    simpa only [d1Expr_context_roundtrip, d0ToD1Expr_mkInst,
+      d1Level_list_roundtrip] using H
+
+noncomputable def d1Ctor (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (d1Params univs))}
+    {Gamma : List (@SExpr (d1Params univs))}
+    (hci : d1Env.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (d1Params univs) c) :
+    letI : Params := d1Params univs
+    {F : CtorBundle c cl //
+      IsDefEqStrong Gamma (SExpr.mkInst ls ci.type)
+        (F.rhs ls) (.sort F.u)} := by
+  letI : Params := d1Params univs
+  let oldGamma := Gamma.map (d1ToD0Expr univs)
+  let oldLs := ls.map (d1ToD0Level univs)
+  have oldHci : d0Env.constants c = some ci :=
+    d1Env_constants_old (d1Ctor_name_ne_mutA univs cl)
+      (d1Ctor_name_ne_mutB univs cl) hci
+  have oldLen : oldLs.length = ci.uvars := by
+    simpa [oldLs] using hlen
+  let oldF : @CtorBundle (d0Params univs) c (d1CtorToD0 univs cl) :=
+    (d0Ctor univs (Gamma := oldGamma) (ls := oldLs)
+      oldHci oldLen (d1CtorToD0 univs cl)).1
+  have oldProof : @IsDefEqStrong (d0Params univs) oldGamma
+      (@SExpr.mkInst (d0Params univs) oldLs ci.type)
+      (@CtorBundle.rhs (d0Params univs) c (d1CtorToD0 univs cl)
+        oldF oldLs)
+      (@SExpr.sort (d0Params univs)
+        (@CtorBundle.u (d0Params univs) c (d1CtorToD0 univs cl) oldF)) :=
+    (d0Ctor univs (Gamma := oldGamma) (ls := oldLs)
+      oldHci oldLen (d1CtorToD0 univs cl)).2
+  let newF := d0CtorBundleToD1 univs cl oldF
+  refine ⟨newF, ?_⟩
+  have H := d0StrongToD1 univs oldProof
+  dsimp only [oldGamma, oldLs] at H
+  simp only [d1Expr_context_roundtrip,
+    d0ToD1Expr_mkInst, d0ToD1Expr_sort] at H
+  rw [d0CtorBundleToD1_rhs univs cl oldF
+    (ls.map (d1ToD0Level univs))] at H
+  simpa only [newF, d1Level_list_roundtrip,
+    d0CtorBundleToD1_u] using H
+
+/-- The D1 iota reduction sites, replayed against the extended environment
+itself.  As in D0, the proof is *not* obtained by casting D1 contexts back
+into the smaller environment: every typing step below is a D1-instance
+derivation, so the certificate remains valid for contexts and captures that
+mention the mutual definitions. -/
+theorem d1IotaSite_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d1Params univs))}
+    {A majorTerm : @SExpr (d1Params univs)}
+    {recLs ctorLs : List (@SLevel (d1Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d1Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d1Params univs)}
+    (rule : @Pattern.IotaRule (d1Params univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d1Params univs))
+    (captureTyping : @Pattern.CaptureTyping (d1Params univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : D1ContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (d1Params univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (d1Params univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (d1Params univs) Gamma
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs)))
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (d1Params univs) Gamma A A
+      (@SExpr.sort (d1Params univs) u)) :
+    Nonempty (@Pattern.IotaReductionSite (d1Params univs) Gamma rec major ctor
+      arity r rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping) := by
+  letI : Params := d1Params univs
+  have hpatD1 := rule.pat
+  change D1Pat _ _ at hpatD1
+  have hpat : NatPat (RecursorIotaPattern rec major ctor arity) r := by
+    cases hpatD1 with
+    | old H =>
+      cases H with
+      | iota H' => exact H'
+  obtain ⟨i, constructor, hentry, hpattern, -⟩ :=
+    VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration hpat
+  change RecursorIotaPattern rec major ctor arity =
+    RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor) at hpattern
+  obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure hentry,
+      NatGeneration.ruleCheck natRuleClosure (List.mem_of_getElem? hentry))
+  have Hgen : NatPat
+      (RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+        (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+        (NatGeneration.ruleArgArity constructor)) rgen := .mk hentry
+  have hr : r ≍ rgen :=
+    (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+      hpat Hgen .refl (Pattern.inter_self _)).2.2
+  have hr' : r = rgen := eq_of_heq hr
+  subst r
+  rcases rule with
+    ⟨rulePat, df, ruleRegistered, rhsClosed, capturePaths, rhsTower⟩
+  change NatGeneration.ruleRHS natRuleClosure hentry =
+    Pattern.RHS.appN (.fixed df.rhs rhsClosed)
+      (capturePaths.map fun path => .var path) at rhsTower
+  rw [natRuleRHS_tower hentry] at rhsTower
+  obtain ⟨hrhs, hpaths⟩ := rhsFixedAppN_inj rhsTower
+  subst capturePaths
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  have hregD1 := ruleRegistered
+  change d1Env.defeqs df at hregD1
+  have hreg : natFinalEnv.defeqs df := by
+    rw [d1Env_defeqs_iff] at hregD1
+    rcases hregD1 with hnewB | hnewA | hold
+    · subst df
+      exact (natRule_rhs_ne_d1MutB hentry hrhs).elim
+    · subst df
+      exact (natRule_rhs_ne_d1MutA hentry hrhs).elim
+    · rw [d0Env_defeqs_iff] at hold
+      rcases hold with hnew0 | hold0
+      · subst df
+        exact (natRule_rhs_ne_d0Def hentry hrhs).elim
+      · exact hold0
+  rw [natFinalEnv_defeqs_iff] at hreg
+  obtain ⟨j, hj⟩ := List.mem_iff_getElem?.mp hreg
+  have hj' : j = 0 ∨ j = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hj
+    have : NatGeneration.generatedRules.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl <;> rcases hj' with rfl | rfl
+  all_goals
+    first
+    | have hc := Option.some.inj
+        (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    | have hc := Option.some.inj
+        (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    first
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleZero_lookup.symm.trans hj)
+    | have hdf := Option.some.inj
+        (probeNatGeneratedRuleSucc_lookup.symm.trans hj)
+    subst df
+  all_goals (try simp at hrhs ⊢)
+  case inl.inl =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatZeroRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.zero := by
+      rw [← hc]
+      exact probeNatZeroCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      d1NatRecEnvLookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      (ci := InductiveFixtures.natType.ctors[0].toVConstant) d1NatZeroEnvLookup
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgs, hcaptures⟩ :=
+      d1ZeroCaptureValues univs matched
+    rw [hctorArgs] at typing matched redexSelf ⊢
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const d1NatRecEnvLookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := d1TypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := d1SpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := d1SpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := d1SpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := d1SpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := d1TypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero [])) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := d1TypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := d1TypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := d1TypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app (SExpr.const ``Nat.zero [])) A (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelTwoLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (d1ProbeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc]
+        (((((SExpr.bvar 2).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive).lift.lift).subst
+          (Subst.one minorZero).lift).inst minorSucc) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope .nil))
+    have hplainExplicit : SpineWF Gamma (d1ProbeNatZeroRuleType univs level)
+        [motive, minorZero, minorSucc] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        [motive, minorZero, minorSucc] A := by
+      rw [d1ProbeNatZeroRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 0 NatGeneration.flatCtors[0]).type)
+        ((natCapturePaths NatGeneration.flatCtors[0]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := d1PathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (d1Env_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : d1Env.HasType univs (Gamma.map SExpr.reify)
+        (probeNatZeroRuleLhsV.instL vls)
+        ((NatGeneration.rule 0 NatGeneration.flatCtors[0]).type.instL vls) := by
+      rw [← probeNatZeroRuleLhsV_eq]
+      exact hlhs.weak0 d1Env_ordered
+    unfold probeNatZeroRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf d1Env_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hcoreV : d1Env.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN (probeNatRuleBindersV.map (VExpr.instL vls))
+          (probeNatZeroRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify]
+        (VExpr.instRev (probeNatZeroRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [d1Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst,
+          VExpr.inst_eq, probeReifySubstOne] using
+          hzeroV
+      refine .cons ?_ .nil
+      simpa [d1Params, vls, VExpr.instL, SExpr.reify,
+        SExpr.reify_subst,
+        SExpr.reify_inst, VExpr.inst_eq, VExpr.instN_eq,
+        VExpr.Subst.liftN,
+        probeReifySubstOne, probeReifySubstLift] using
+        hsuccV
+    have hspineV := hcoreV
+    have hspineBody := VEnv.SpineWF.retarget hspineV
+      (by simp [probeNatRuleBindersV])
+      bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN d1Env_ordered
+      hTel hbody hspineBody (by simp [probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong d1Env_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (d1StructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (d1Params univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatZeroRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          (VExpr.const ``Nat.zero [])) := by
+      simp [probeNatZeroRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelTwoLifts, VExpr.inst_lift]
+      simpa only [VExpr.liftN_zero] using
+        probeVCancelTwoLifts motive.reify minorZero.reify minorSucc.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify])) := by
+      rw [probeNatZeroRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatZeroRuleLhsV,
+        probeNatRuleBindersV, probeNatZeroRuleLhsBodyV,
+        VExpr.lamN, VExpr.appN,
+        probeVCancelTwoLifts, VExpr.inst_lift, SExpr.mk,
+        SExpr.mkInst] using
+        hcollapseS
+    obtain ⟨_, hcollapseType⟩ := d1TypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app (SExpr.const ``Nat.zero []))
+        ([motive, minorZero, minorSucc].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 0 NatGeneration.flatCtors[0]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatZeroRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+  case inl.inr =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs)).elim
+  case inr.inl =>
+    subst constructor
+    exact (probeNatRuleRhs_ne (by simpa using hrhs.symm)).elim
+  case inr.inr =>
+    have hrecName : NatGeneration.ruleRecName constructor = ``Nat.rec := by
+      rw [← hc]
+      exact probeNatSuccRuleRecName
+    have hctorName : constructor.ctor.raw.name = ``Nat.succ := by
+      rw [← hc]
+      exact probeNatSuccCtorName
+    simp only [hrecName, hctorName] at typing matched redexSelf
+    subst constructor
+    have hrecLen := typing.recHead.const_left_levelsLength
+      d1NatRecEnvLookup
+    change recLs.length = 1 at hrecLen
+    obtain ⟨level, rfl⟩ := List.length_eq_one_iff.mp hrecLen
+    have hctorLen := typing.ctorHead.const_left_levelsLength
+      d1NatSuccEnvLookup
+    change ctorLs.length = 0 at hctorLen
+    have hctorLs : ctorLs = [] := List.length_eq_zero_iff.mp hctorLen
+    subst ctorLs
+    obtain ⟨hrecArgsLen, hctorArgsLen, hcaptures⟩ :=
+      d1SuccCaptureValues univs matched
+    obtain ⟨pred, rfl⟩ := List.length_eq_one_iff.mp hctorArgsLen
+    have hrecArgs : ∃ x y z, recArgs = [x, y, z] :=
+      ⟨recArgs[0], recArgs[1], recArgs[2],
+        List.eq_getElem_of_length_eq_three recArgs hrecArgsLen⟩
+    obtain ⟨minorSucc, minorZero, motive, rfl⟩ := hrecArgs
+    have hrecCanonical : IsDefEq Gamma
+        (.const ``Nat.rec [level]) (.const ``Nat.rec [level])
+        (SExpr.mkInst [level]
+          (VInductDecl.recConst 0 ``Nat 0 InductiveFixtures.natType).type) :=
+      .const d1NatRecEnvLookup rfl
+    rw [probeNatRecTypeV_eq] at hrecCanonical
+    have hheadEq := d1TypeUniq univs hGamma hrecCanonical typing.recHead
+    let motiveView := d1SpineConsView univs hGamma hheadEq typing.recSpine
+    have hmotive := motiveView.argumentExpected univs
+    have hrestMotive := motiveView.restEq univs
+    let zeroView := d1SpineConsView univs hGamma hrestMotive motiveView.tail
+    have hzero := zeroView.argumentExpected univs
+    have hrestZero := zeroView.restEq univs
+    let succView := d1SpineConsView univs hGamma hrestZero zeroView.tail
+    have hsucc := succView.argumentExpected univs
+    have hrestSucc := succView.restEq univs
+    let majorView := d1SpineConsView univs hGamma hrestSucc succView.tail
+    have hmajor := majorView.argumentExpected univs
+    have hctorCanonical : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (SExpr.mkInst [] InductiveFixtures.natType.ctors[1].type) :=
+      .const d1NatSuccEnvLookup rfl
+    rw [probeNatSuccCtorTypeV_eq] at hctorCanonical
+    have hctorCanonical' : IsDefEq Gamma
+        (.const ``Nat.succ []) (.const ``Nat.succ [])
+        (.forallE (.const ``Nat []) (.const ``Nat [])) := by
+      simpa [SExpr.mkInst] using hctorCanonical
+    have hctorType := d1TypeUniq univs hGamma
+      hctorCanonical' typing.ctorHead
+    let predView := d1SpineConsView univs hGamma hctorType typing.ctorSpine
+    have hpred := predView.argumentExpected univs
+    have hpred' : IsDefEq Gamma pred pred (.const ``Nat []) := by
+      simpa using hpred
+    have hprefixMotive := IsDefEq.appDF hrecCanonical hmotive
+    have hprefixZero := IsDefEq.appDF hprefixMotive hzero
+    have hprefixSucc := IsDefEq.appDF hprefixZero hsucc
+    obtain ⟨_, hmajorType⟩ := d1TypeUniq univs hGamma
+      typing.majorEq.hasType.1 hmajor
+    have hmajorEq := hmajorType.defeqDF typing.majorEq
+    have hredexAtGenerated := IsDefEq.appDF hprefixSucc hmajorEq
+    have hctorAtRuleResult :=
+      IsDefEq.appDF hprefixSucc hmajorEq.hasType.2
+    have redexSelf' : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app
+            ((SExpr.const ``Nat.succ []).app pred)) A := by
+      simpa using redexSelf
+    obtain ⟨_, hruleMajor⟩ := d1TypeUniq univs hGamma
+      hctorAtRuleResult hredexAtGenerated.hasType.2
+    obtain ⟨_, hmajorA⟩ := d1TypeUniq univs hGamma
+      hredexAtGenerated.hasType.2 redexSelf'
+    have hruleA := d1TypesTrans univs hGamma
+      ⟨_, hruleMajor⟩ ⟨_, hmajorA⟩
+    obtain ⟨ruleSort, hruleA⟩ := hruleA
+    have hruleA' : IsDefEq Gamma
+        (motive.app ((SExpr.const ``Nat.succ []).app pred)) A
+        (.sort ruleSort) := by
+      simpa [SExpr.mkInst, SExpr.inst, SExpr.subst, Subst.lift,
+        Subst.cons, Subst.id, probeCancelThreeLifts] using hruleA
+    have hmotive' : IsDefEq Gamma motive motive
+        (.forallE (.const ``Nat []) (.sort level)) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, probeInstVParamZero] using hmotive
+    have hzero' : IsDefEq Gamma minorZero minorZero
+        (motive.app (.const ``Nat.zero [])) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id] using hzero
+    have hsucc' : IsDefEq Gamma minorSucc minorSucc
+        (.forallE (SExpr.const ``Nat [])
+          (.forallE
+            (motive.lift.app (SExpr.bvar 0))
+            (motive.lift.lift.app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))) := by
+      simpa [probeNatRecTypeV, SExpr.mkInst, SExpr.inst, SExpr.subst,
+        Subst.lift, Subst.cons, Subst.id, probeCancelTwoLifts,
+        probeCancelUnderOne, probeCancelUnderTwo,
+        probeInstVParamZero] using hsucc
+    have hruleAForTelescope : IsDefEq Gamma
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred)
+        A (.sort ruleSort) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelThreeLifts] using hruleA'
+    have hzeroForTelescope : IsDefEq Gamma minorZero minorZero
+        (((SExpr.bvar 0).app (SExpr.const ``Nat.zero [])).subst
+          (Subst.one motive)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id] using hzero'
+    have hsuccForTelescope : IsDefEq Gamma minorSucc minorSucc
+        (((SExpr.forallE (SExpr.const ``Nat [])
+          (SExpr.forallE
+            ((SExpr.bvar 2).app (SExpr.bvar 0))
+            ((SExpr.bvar 3).app
+              ((SExpr.const ``Nat.succ []).app (SExpr.bvar 1))))).subst
+          (Subst.one motive).lift).subst (Subst.one minorZero)) := by
+      simpa [SExpr.inst, SExpr.subst, Subst.lift, Subst.cons,
+        Subst.id, probeCancelUnderOne, probeCancelUnderTwo] using hsucc'
+    have hcoreExplicit : SpineWF Gamma (d1ProbeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred]
+        ((((((SExpr.bvar 3).app
+          ((SExpr.const ``Nat.succ []).app (SExpr.bvar 0))).subst
+            (Subst.one motive).lift.lift.lift).subst
+            (Subst.one minorZero).lift.lift).subst
+            (Subst.one minorSucc).lift).inst pred) := by
+      exact .cons hmotive' (.cons hzeroForTelescope
+        (.cons hsuccForTelescope (.cons hpred' .nil)))
+    have hplainExplicit : SpineWF Gamma (d1ProbeNatSuccRuleType univs level)
+        [motive, minorZero, minorSucc, pred] A :=
+      .ret hcoreExplicit hruleAForTelescope
+    have hplain : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        [motive, minorZero, minorSucc, pred] A := by
+      rw [d1ProbeNatSuccRuleTypeS_eq]
+      exact hplainExplicit
+    have hplainPaths : SpineWF Gamma
+        (SExpr.mkInst [level]
+          (NatGeneration.rule 1 NatGeneration.flatCtors[1]).type)
+        ((natCapturePaths NatGeneration.flatCtors[1]).map mcap) A := by
+      exact hcaptures.symm ▸ hplain
+    have captureSpine := d1PathSpineOfSpineWF univs hGamma
+      captureTyping.typed hplainPaths
+    let vls : List VLevel := [level.reify]
+    have hvls : ∀ l ∈ vls, l.WF univs := by
+      intro l hl
+      simp only [vls, List.mem_singleton] at hl
+      subst l
+      exact SLevel.reify_wf level
+    have hlhs :=
+      (d1Env_ordered.defEqWF ruleRegistered).1.instL hvls
+    have hlhsGamma : d1Env.HasType univs (Gamma.map SExpr.reify)
+        (probeNatSuccRuleLhsV.instL vls)
+        ((NatGeneration.rule 1 NatGeneration.flatCtors[1]).type.instL vls) := by
+      rw [← probeNatSuccRuleLhsV_eq]
+      exact hlhs.weak0 d1Env_ordered
+    unfold probeNatSuccRuleLhsV at hlhsGamma
+    rw [VExpr.instL_lamN] at hlhsGamma
+    obtain ⟨hTel, bodyType, hbody⟩ :=
+      VEnv.HasType.lamN_wf d1Env_ordered hGamma hlhsGamma
+    have hmotiveV := hmotive'.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      motive.reify motive.reify _ at hmotiveV
+    have hzeroV := hzeroForTelescope.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorZero.reify minorZero.reify _ at hzeroV
+    have hsuccV := hsuccForTelescope.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      minorSucc.reify minorSucc.reify _ at hsuccV
+    have hpredV := hpred'.reify hGamma
+    change d1Env.IsDefEq univs (Gamma.map SExpr.reify)
+      pred.reify pred.reify _ at hpredV
+    have hcoreV : d1Env.SpineWF univs (Gamma.map SExpr.reify)
+        (VExpr.forallN
+          (probeNatSuccRuleBindersV.map (VExpr.instL vls))
+          (probeNatSuccRuleResultV.instL vls))
+        [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]
+        (VExpr.instRev (probeNatSuccRuleResultV.instL vls)
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify]) := by
+      refine .cons hmotiveV ?_
+      refine .cons ?_ ?_
+      · simpa [d1Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, VExpr.inst_eq, probeReifySubstOne] using hzeroV
+      refine .cons ?_ ?_
+      · simpa [d1Params, vls, VExpr.instL, SExpr.reify,
+          SExpr.reify_subst, SExpr.reify_inst, VExpr.inst_eq,
+          VExpr.instN_eq, VExpr.Subst.liftN, probeReifySubstOne,
+          probeReifySubstLift] using hsuccV
+      refine .cons ?_ .nil
+      simpa [d1Params, vls, VExpr.instL, VExpr.inst, SExpr.reify] using hpredV
+    have hspineBody := VEnv.SpineWF.retarget hcoreV
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV]) bodyType
+    have hcollapseV := VEnv.IsDefEq.appN_lamN d1Env_ordered
+      hTel hbody hspineBody
+      (by simp [probeNatSuccRuleBindersV, probeNatRuleBindersV])
+    have hlevels :=
+      (VEnv.CtxStrong.strong d1Env_ordered hGamma).levelWF
+    have hcollapseS := SExpr.IsDefEq.mkS (d1StructureEtaSound univs)
+      hcollapseV hlevels
+    have hctx : (Gamma.map SExpr.reify).map SExpr.mk = Gamma := by
+      rw [List.map_map]
+      exact List.map_id''' Gamma fun term _ => SExpr.mk_reify term
+    rw [hctx] at hcollapseS
+    have hmkInst (e : VExpr) :
+        SExpr.mk (e.instL vls) = SExpr.mkInst [level] e := by
+      unfold vls
+      exact @SExpr.mk_instL_map_reify (d1Params univs) e [level]
+    have hlevelMk :
+        SLevel.mk (VLevel.inst vls (VLevel.param 0)) = level := by
+      simp [vls, probeReifyInstVParamZero, SLevel.mk_reify]
+    have hbodyCollapseV :
+        (probeNatSuccRuleLhsBodyV.instL vls).instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify] =
+        (((((VExpr.const ``Nat.rec [level.reify]).app motive.reify).app
+          minorZero.reify).app minorSucc.reify).app
+          ((VExpr.const ``Nat.succ []).app pred.reify)) := by
+      simp [probeNatSuccRuleLhsBodyV, vls, VExpr.instRev, VExpr.instL,
+        VExpr.inst, VExpr.instVar, VExpr.liftN, liftVar,
+        VExpr.liftN_succ, VExpr.liftN_zero, probeReifyInstVParamZero,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift]
+      constructor
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelThreeLifts motive.reify minorZero.reify
+            minorSucc.reify pred.reify
+      · simpa only [VExpr.liftN_zero] using
+          probeVCancelTwoLifts minorZero.reify minorSucc.reify pred.reify
+    rw [hbodyCollapseV] at hcollapseS
+    have hcollapseCanonical : IsDefEq Gamma
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs))
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        (SExpr.mk (bodyType.instRev
+          [motive.reify, minorZero.reify, minorSucc.reify, pred.reify])) := by
+      rw [probeNatSuccRuleLhsV_eq]
+      simpa [vls, hmkInst, hlevelMk, probeNatSuccRuleLhsV,
+        probeNatSuccRuleBindersV, probeNatRuleBindersV,
+        probeNatSuccRuleLhsBodyV, VExpr.lamN, VExpr.appN,
+        probeVCancelThreeLifts, probeVCancelTwoLifts, VExpr.inst_lift,
+        SExpr.mk, SExpr.mkInst] using hcollapseS
+    obtain ⟨_, hcollapseType⟩ := d1TypeUniq univs hGamma
+      hcollapseCanonical.hasType.2 redexSelf'
+    have lhsCollapseCanonical : IsDefEq Gamma
+        (((((SExpr.const ``Nat.rec [level]).app motive).app minorZero).app
+          minorSucc).app ((SExpr.const ``Nat.succ []).app pred))
+        ([motive, minorZero, minorSucc, pred].foldl
+          (fun (f a : SExpr) => f.app a)
+          (SExpr.mkInst [level]
+            (NatGeneration.rule 1 NatGeneration.flatCtors[1]).lhs)) A :=
+      hcollapseType.defeqDF hcollapseCanonical.symm
+    refine ⟨{
+      typing := typing
+      matched := matched
+      levelsLength := by rfl
+      captureSpine := captureSpine
+      lhsCollapse := ?_
+      dfs := []
+      defeqs := by rfl
+      checked := by simp }⟩
+    simpa [probeNatSuccRuleRecName] using
+      (hcaptures.symm ▸ lhsCollapseCanonical)
+
+noncomputable def d1IotaSite (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d1Params univs))}
+    {A majorTerm : @SExpr (d1Params univs)}
+    {recLs ctorLs : List (@SLevel (d1Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d1Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d1Params univs)}
+    (rule : @Pattern.IotaRule (d1Params univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d1Params univs))
+    (captureTyping : @Pattern.CaptureTyping (d1Params univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : D1ContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (d1Params univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (d1Params univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs))) recLs mcap)
+    (redexSelf : @IsDefEq (d1Params univs) Gamma
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs)))
+      (@SExpr.app (d1Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d1Params univs) f a)
+          (@SExpr.const (d1Params univs) ctor ctorLs))) A)
+    (AType : ∃ u, @IsDefEq (d1Params univs) Gamma A A
+      (@SExpr.sort (d1Params univs) u)) :
+    @Pattern.IotaReductionSite (d1Params univs) Gamma rec major ctor
+      arity r rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping :=
+  Classical.choice (d1IotaSite_nonempty univs rule captureType captureTyping
+    hGamma typing matched redexSelf AType)
+
+/-- The complete D1 bridge: generated Nat iota, the inherited `d0def`
+unfolding, and the checked mutual definition block, all against the extended
+environment. -/
+noncomputable def d1Semantic (univs : Nat) :
+    letI : Params := d1Params univs
+    Params.Semantic := by
+  letI : Params := d1Params univs
+  exact {
+  structureEta := by
+    intro rule levels Gamma params major hreg
+    exact (d1Env_no_structEta rule hreg).elim
+  ctor := by
+    intro c ci ls Gamma hci hlen cl
+    exact d1Ctor univs hci hlen cl
+  defn := by
+    intro c r hpat
+    exact d1Defn univs hpat
+  iotaRule := by
+    intro rec major ctor arity r hpat
+    exact d1IotaRule univs hpat
+  iotaSite := by
+    intro rec major ctor arity r Gamma A majorTerm recLs ctorLs
+      recArgs ctorArgs mcap rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+    exact d1IotaSite univs rule captureType captureTyping hGamma typing
+      matched redexSelf AType
+  registered := by
+    intro df ls Gamma hreg hlen hLhs hRhs
+    exact d1Registered univs hreg hlen hLhs hRhs }
+
+/-! ## Concrete δ-rank certificate
+
+The mutual block is ranked by dependency, not declaration order:
+`d1mutA` unfolds to `d1mutB`, and `d1mutB` unfolds through `d0def`.
+Thus their ranks are respectively three, two, and one. -/
+
+def d1DeltaRankFn : Name → Nat := fun n =>
+  if n = ``ParamsD1.d1mutA then 3
+  else if n = ``ParamsD1.d1mutB then 2
+  else if n = ``ParamsD0.d0def then 1
+  else 0
+
+theorem d1NatTypeLookup :
+    d1Env.constants ``Nat = some InductiveFixtures.natType.toVConstant :=
+  d0Env_le_d1Env.constants d0NatTypeLookup
+
+theorem d1D0DefLookup :
+    d1Env.constants ``ParamsD0.d0def = some d0DefVal.toVConstant :=
+  d0Env_le_d1Env.constants d0Env_d0Def_lookup
+
+theorem d1DeltaRankFn_nat : d1DeltaRankFn ``Nat ≤ 0 := by decide
+
+theorem d1DeltaRankFn_natZero : d1DeltaRankFn ``Nat.zero ≤ 0 := by
+  decide
+
+theorem d1DeltaRankFn_natSucc : d1DeltaRankFn ``Nat.succ ≤ 0 := by
+  decide
+
+theorem d1DeltaRankFn_d0def :
+    d1DeltaRankFn ``ParamsD0.d0def ≤ 1 := by
+  decide
+
+theorem d1DeltaRankFn_d1mutB :
+    d1DeltaRankFn ``ParamsD1.d1mutB ≤ 2 := by
+  decide
+
+/-- `Nat : Type` in D1 at rank zero. -/
+theorem d1NatCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.const ``Nat []) (.sort (.instV [] (.succ .zero))) true (n + 1) 0 := by
+  letI : Params := d1Params univs
+  intro Gamma n
+  exact .base (.const d1NatTypeLookup rfl d1DeltaRankFn_nat
+    (.base .sort'))
+
+/-- `Nat → Nat : Type` in D1 at rank zero. -/
+theorem d1NatPiCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.forallE (.const ``Nat []) (.const ``Nat []))
+        (.sort (.imax (.instV [] (.succ .zero))
+          (.instV [] (.succ .zero)))) true (n + 2) 0 := by
+  letI : Params := d1Params univs
+  intro Gamma n
+  exact .base (.forallE (d1NatCertR univs Gamma n)
+    (d1NatCertR univs (_ :: Gamma) n))
+
+/-- `Nat.succ : Nat → Nat` in D1 at rank zero. -/
+theorem d1SuccCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.const ``Nat.succ [])
+        (.forallE (.const ``Nat []) (.const ``Nat [])) true (n + 3) 0 := by
+  letI : Params := d1Params univs
+  intro Gamma n
+  exact .base (.const d1NatSuccEnvLookup rfl d1DeltaRankFn_natSucc
+    (d1NatPiCertR univs Gamma n))
+
+/-- `Nat.zero : Nat` in D1 at rank zero. -/
+theorem d1ZeroCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.const ``Nat.zero []) (.const ``Nat []) true 2 0 := by
+  letI : Params := d1Params univs
+  intro Gamma
+  exact .base (.const d1NatZeroEnvLookup rfl d1DeltaRankFn_natZero
+    (d1NatCertR univs Gamma 0))
+
+/-- `d0def : Nat` as a used constant, at rank one. -/
+theorem d1D0DefConstCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.const ``ParamsD0.d0def []) (.const ``Nat []) true (n + 2) 1 := by
+  letI : Params := d1Params univs
+  intro Gamma n
+  exact .base (.const d1D0DefLookup rfl d1DeltaRankFn_d0def
+    ((d1NatCertR univs Gamma n).mono_rank (Nat.zero_le 1)))
+
+/-- `Nat.succ d0def : Nat` at rank one, the body certificate for
+`d1mutB`. -/
+theorem d1MutBValueCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.app (.const ``Nat.succ []) (.const ``ParamsD0.d0def []))
+        (.const ``Nat []) true 4 1 := by
+  letI : Params := d1Params univs
+  intro Gamma
+  refine .base (.app (u := .instV [] (.succ .zero))
+    (v := .instV [] (.succ .zero))
+    ((d1NatCertR univs Gamma 2).mono_rank (Nat.zero_le 1))
+    ((d1NatCertR univs (_ :: Gamma) 2).mono_rank (Nat.zero_le 1))
+    ((d1SuccCertR univs Gamma 0).mono_rank (Nat.zero_le 1))
+    (d1D0DefConstCertR univs Gamma 1)
+    ((d1NatCertR univs Gamma 2).mono_rank (Nat.zero_le 1)))
+
+/-- `d1mutB : Nat` as a used constant, at rank two, the body certificate
+for `d1mutA`. -/
+theorem d1MutBConstCertR (univs : Nat) :
+    letI : Params := d1Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d1DeltaRankFn Gamma
+        (.const ``ParamsD1.d1mutB []) (.const ``Nat []) true 2 2 := by
+  letI : Params := d1Params univs
+  intro Gamma
+  exact .base (.const d1Env_d1MutB_lookup rfl d1DeltaRankFn_d1mutB
+    ((d1NatCertR univs Gamma 0).mono_rank (Nat.zero_le 2)))
+
+/-- The D1 fixture's checked δ-rank certificate. -/
+def d1DeltaRank (univs : Nat) :
+    letI : Params := d1Params univs
+    Params.DeltaRank := by
+  letI : Params := d1Params univs
+  refine ⟨d1DeltaRankFn, ?_⟩
+  intro c ci value closed ls Gamma hpat hreg hlen
+  change D1Pat _ _ at hpat
+  cases hpat with
+  | old h0 =>
+    cases h0 with
+    | iota h => exact (natPat_no_const univs h).elim
+    | defn =>
+      obtain rfl := Option.some.inj (d1D0DefLookup.symm.trans hreg)
+      obtain rfl := List.length_eq_zero_iff.mp hlen
+      exact ⟨2, 0, by decide, d1ZeroCertR univs Gamma⟩
+  | defnA =>
+    obtain rfl := Option.some.inj (d1Env_d1MutA_lookup.symm.trans hreg)
+    obtain rfl := List.length_eq_zero_iff.mp hlen
+    exact ⟨2, 2, by decide, d1MutBConstCertR univs Gamma⟩
+  | defnB =>
+    obtain rfl := Option.some.inj (d1Env_d1MutB_lookup.symm.trans hreg)
+    obtain rfl := List.length_eq_zero_iff.mp hlen
+    exact ⟨4, 1, by decide, d1MutBValueCertR univs Gamma⟩
+
+/-- End-to-end D1 endpoint: the mutual-definition-extended environment
+supplies every semantic certificate required by the experimental
+sort-injectivity bridge. -/
+theorem d1SortInvS (univs : Nat) {Gamma : List VExpr} {u v : VLevel}
+    (hGamma : OnCtx Gamma (d1Env.IsType univs))
+    (h : d1Env.IsDefEqU univs Gamma (.sort u) (.sort v)) : u ≈ v := by
+  letI : Params := d1Params univs
+  letI : Params.Semantic := d1Semantic univs
+  exact VEnv.IsDefEqU.sort_invS hGamma h
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD1.d1SortInvS' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_3,
+ probeNatGeneratedRuleSucc_lookup._native.native_decide.ax_1_1,
+ probeNatGeneratedRuleZero_lookup._native.native_decide.ax_1_1,
+ probeNatRecTypeV_eq._native.native_decide.ax_1_1,
+ probeNatRuleRhs_ne._native.native_decide.ax_1_1,
+ probeNatSuccCtorName._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleRecName._native.native_decide.ax_1_1,
+ probeNatSuccRuleTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ probeNatZeroCtorName._native.native_decide.ax_1_1,
+ probeNatZeroRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatZeroRuleRecName._native.native_decide.ax_1_1,
+ probeNatZeroRuleTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_3,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_3]
+-/
+#guard_msgs in
+#print axioms d1SortInvS
+
+end SemanticCertificates
+
+/-! ## Quotient half of the D1 plan line: environment layer and the
+interface obstruction
+
+`plans/l4l-16-completion-plan.md` assigns `CertifiedExtension.quot` to D1.
+The environment-layer content is deliverable and is checked below: the D1
+environment extends by the `Eq` axiom and the checked `.quot` history step
+(`VDecl.WF.quot`), producing a WF/Ordered environment that registers
+`quotDefEq`.
+
+The *semantic* half is not instantiable under the current interface, for
+three independent reasons, in escalating strength:
+
+1. `Params.pat_wf` forces `classify ``Quot.mk = some (.ctor 3)` whenever
+   the quot pattern is in `Pat` (`quotPattern_forces_ctor_classification`
+   below is the kernel-checked forcing step).  Then `CtorBundle.IsCtor
+   ``Quot.mk` holds, and `Params.Semantic.ctor` must produce a
+   `CtorBundle` at *every* `ls` with `ls.length = 1` — including
+   `ls = [.zero]`, where `mkInst ls quotMkConst.type` is a `Prop`
+   (its sort evaluates to `imax 1 (imax 1 0) = 0`), so the bundle's
+   equality at `.sort F.u` forces `F.u = .zero` against `CtorBundle.hu0`.
+   This is exactly the punit disqualification recorded in
+   `plans/l4l-16d0-slice-map.md` (Prop-instantiable constructor); the
+   plan's non-Prop staging note (Nat, List, tree blocks) already excludes
+   such constructors from the pre-L4L-17 stage.
+2. Keeping the pattern out of `Pat` but `quotDefEq` in `env.defeqs`
+   instead breaks `Params.Semantic.registered`: the required strong
+   equality between the two six-binder towers has a stuck
+   `Quot.lift … (Quot.mk …)` head, and without a `Pat` member neither
+   `.extra` (needs a `Pattern.Action`, hence a member) nor `defn`
+   (constant patterns only) can derive it.
+3. Even with 1 repaired, `Params.Semantic.iotaSite` for the quot rule
+   must discharge `quotCheck`'s two obligations (`α' ≡ α`, `r' ≡ r`)
+   from its typing inputs alone; that needs injectivity of the stuck
+   application `@Quot α r ≡ @Quot α' r'`, a Church–Rosser-strength
+   inversion the current system defers to L4L-18A′.
+
+Repair options are an interface decision owned by the 16C′ writer (e.g. a
+typing-conditional `hu0`, or restricting `Semantic.ctor`'s level
+quantification to well-sorted instantiations); none is taken here.  The D1
+deliverable for the quotient is therefore the environment layer plus this
+record. -/
+
+section QuotObstruction
+
+open VInductDecl
+
+/-- Any classifier making the quot pattern well-formed marks `Quot.mk` as a
+three-argument constructor head.  This is the forcing step of obstruction 1:
+pattern membership alone commits the semantic instance to constructor
+bundles for `Quot.mk` at every universe instantiation. -/
+theorem quotPattern_forces_ctor_classification
+    (cl : Name → Option Classification)
+    (H : (CertifiedExtension.quotPattern.toPattern).WF cl) :
+    cl ``Quot.mk = some (.ctor 3) := by
+  have h := H
+  simp only [CertifiedExtension.quotPattern, SimplePattern.toPattern,
+    RecursorIotaPattern, Pattern.varN, Pattern.WF] at h
+  exact h.2
+
+/-- The `Eq` head declared as an axiom over the D1 environment. -/
+def d1qEqVal : VConstVal := ⟨eqConst, ``Eq⟩
+
+theorem d1qEq_fresh : d1Env.constants ``Eq = none := by native_decide
+
+local instance : Inhabited VEnv := ⟨VEnv.empty⟩
+
+def d1qEqEnv := (d1Env.addConst ``Eq eqConst).get!
+
+theorem d1Env_add_eq : d1Env.addConst ``Eq eqConst = some d1qEqEnv := by
+  simp [VEnv.addConst, d1qEq_fresh, d1qEqEnv]
+
+theorem d1qEqEnv_quotReady : d1qEqEnv.QuotReady :=
+  VEnv.addConst_self d1Env_add_eq
+
+theorem d1qEqVal_wf : d1qEqVal.toVConstant.WF d1Env := by
+  have hp : VLevel.WF 1 (.param 0) := Nat.one_pos
+  have hz : VLevel.WF 1 .zero := trivial
+  have hα : _root_.Lean4Lean.Lookup [VExpr.sort (.param 0)] 0
+      (.sort (.param 0)) := .zero
+  have hx : _root_.Lean4Lean.Lookup [VExpr.bvar 0, VExpr.sort (.param 0)] 1
+      (.sort (.param 0)) := .succ .zero
+  exact ⟨_, VEnv.HasType.forallE (VEnv.HasType.sort hp)
+    (VEnv.HasType.forallE (VEnv.HasType.bvar hα)
+      (VEnv.HasType.forallE (VEnv.HasType.bvar hx)
+        (VEnv.HasType.sort hz)))⟩
+
+theorem d1qEq_step : VDecl.WF d1Env (.axiom d1qEqVal) d1qEqEnv :=
+  .axiom d1qEqVal_wf d1Env_add_eq
+
+def d1qQuotEnv1 := (d1qEqEnv.addConst ``Quot quotConst).get!
+def d1qQuotEnv2 := (d1qQuotEnv1.addConst ``Quot.mk quotMkConst).get!
+def d1qQuotEnv3 := (d1qQuotEnv2.addConst ``Quot.lift quotLiftConst).get!
+def d1qQuotEnv4 := (d1qQuotEnv3.addConst ``Quot.ind quotIndConst).get!
+
+/-- The complete quotient-extended environment. -/
+def d1qEnv := d1qQuotEnv4.addDefEq quotDefEq
+
+theorem d1qQuot_fresh : d1qEqEnv.constants ``Quot = none := by
+  native_decide
+
+theorem d1qQuotMk_fresh : d1qQuotEnv1.constants ``Quot.mk = none := by
+  native_decide
+
+theorem d1qQuotLift_fresh : d1qQuotEnv2.constants ``Quot.lift = none := by
+  native_decide
+
+theorem d1qQuotInd_fresh : d1qQuotEnv3.constants ``Quot.ind = none := by
+  native_decide
+
+theorem d1qEqEnv_add1 :
+    d1qEqEnv.addConst ``Quot quotConst = some d1qQuotEnv1 := by
+  simp [VEnv.addConst, d1qQuot_fresh, d1qQuotEnv1]
+
+theorem d1qQuotEnv1_add2 :
+    d1qQuotEnv1.addConst ``Quot.mk quotMkConst = some d1qQuotEnv2 := by
+  simp [VEnv.addConst, d1qQuotMk_fresh, d1qQuotEnv2]
+
+theorem d1qQuotEnv2_add3 :
+    d1qQuotEnv2.addConst ``Quot.lift quotLiftConst = some d1qQuotEnv3 := by
+  simp [VEnv.addConst, d1qQuotLift_fresh, d1qQuotEnv3]
+
+theorem d1qQuotEnv3_add4 :
+    d1qQuotEnv3.addConst ``Quot.ind quotIndConst = some d1qQuotEnv4 := by
+  simp [VEnv.addConst, d1qQuotInd_fresh, d1qQuotEnv4]
+
+theorem d1qEqEnv_addQuot : d1qEqEnv.addQuot = some d1qEnv := by
+  simp [VEnv.addQuot, d1qEqEnv_add1, d1qQuotEnv1_add2,
+    d1qQuotEnv2_add3, d1qQuotEnv3_add4, d1qEnv]
+
+theorem d1qQuot_step : VDecl.WF d1qEqEnv .quot d1qEnv :=
+  .quot d1qEqEnv_quotReady d1qEqEnv_addQuot
+
+/-- The quotient-extended environment is well-formed by declaration
+history: the D1 history followed by the `Eq` axiom and the checked `.quot`
+step. -/
+theorem d1qEnv_wf : d1qEnv.WF := by
+  obtain ⟨ds, hds⟩ := d1Env_wf
+  exact ⟨.quot :: .axiom d1qEqVal :: ds,
+    .decl d1qQuot_step (.decl d1qEq_step hds)⟩
+
+theorem d1qEnv_ordered : d1qEnv.Ordered := d1qEnv_wf.ordered
+
+/-- The registered quotient contraction rule, exactly the payload certified
+by `CertifiedExtension.quot`. -/
+theorem d1qEnv_defeq_quot : d1qEnv.defeqs quotDefEq :=
+  VEnv.addQuot_defeq d1qEqEnv_addQuot
+
+/- The quotient environment layer carries no inherited admissions: unlike
+the semantic endpoint, its closure is `sorryAx`-free — only the standard
+logical axioms, the fixture persistent-map contracts, and named concrete
+`native_decide` observations. -/
+/--
+info: 'Lean4Lean.SExpr.ParamsD1.d1qEnv_wf' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1qEq_fresh._native.native_decide.ax_1_1,
+ d1qQuotInd_fresh._native.native_decide.ax_1_1,
+ d1qQuotLift_fresh._native.native_decide.ax_1_1,
+ d1qQuotMk_fresh._native.native_decide.ax_1_1,
+ d1qQuot_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d1qEnv_wf
+
+end QuotObstruction
+
+end ParamsD1
+end SExpr
+end Lean4Lean
diff --git a/Lean4Lean/Experimental/SExprParamsD2.lean b/Lean4Lean/Experimental/SExprParamsD2.lean
new file mode 100644
index 00000000..8e972348
--- /dev/null
+++ b/Lean4Lean/Experimental/SExprParamsD2.lean
@@ -0,0 +1,3641 @@
+import Lean4Lean.Experimental.SExprParamsD1
+import Lean4Lean.Experimental.SExprTransport
+import Lean4Lean.Experimental.SExprGenericReplay
+import Lean4Lean.Verify.Environment.MutualInductiveFixtures
+import Lean4Lean.Theory.Typing.InductivePatternFixtures
+
+/-!
+# L4L-16D2: a live block-inductive environment over the D1 fixture
+
+This module extends the kernel-checked D1 instance
+(`Lean4Lean/Experimental/SExprParamsD1.lean`) with the next staged slice of
+live-environment coverage: a genuine *mutual inductive block* declaration
+step.  The block is the real `Tree`/`TreeList` pair of
+`Lean4Lean/Theory/MutualInductiveFixtures.lean` — two families, five
+flattened constructors, two recursors, five generated iota rules — added to
+`d1Env` by a checked `VDecl.WF.inductBlock` history step.
+
+The pattern layer is the first live consumer of the union-level non-overlap
+laws landed in `Theory/Typing/InductivePatternEnv.lean`: the block's five
+generated rules and the three D1 *definition* rules are packaged as one
+`AssembledPat` whose `ExtSeparation` certificate is discharged by kernel
+`decide` through the block's rule-pattern inventory.
+
+Scope note.  The `Params.Semantic` bridge is *not* completed here.  Four of
+its six fields are delivered (see `d2StructureEtaSound`, `d2IotaRule`, and
+the transport-free observations below); `iotaSite` and `registered` for the
+five *new* block rules require the full evidence-rich reduction-site replay
+that D0/D1 performed per Nat rule, which is a bounded but large piece of
+work.  The obstruction is recorded precisely at the end of this file, in the
+same style as D1's quotient record.
+-/
+
+namespace Lean4Lean
+namespace SExpr
+namespace ParamsD2
+
+open InductiveFixtures InductiveReplayFixtures VInductDecl
+open MutualInductiveFixtures MutualInductiveReplayFixtures
+open ParamsD0 ParamsD1
+
+/-! ## D2 block data
+
+`treeGeneration` is the certified block-wide generation descriptor of the
+real `Tree`/`TreeList` declaration, together with the semantic package
+`treeBlockGenerationWF` proved over the empty environment in
+`Verify/Environment/MutualInductiveFixtures.lean`.  Nothing about the block
+is re-derived here; the D2 work is re-basing that package onto `d1Env` and
+consuming it. -/
+
+/-- The certified mutual block used by D2. -/
+abbrev TreeGen := MutualInductiveFixtures.treeGeneration
+
+/-- The five generated iota RHS towers and index towers are closed. -/
+theorem treeRuleClosure : TreeGen.RuleClosure :=
+  VInductDecl.BlockGenerationChecked.RuleClosure.of_all _
+    (by decide) (by decide)
+
+/-- The block's rule-pattern inventory, kernel-checked.  Majors count the
+shared parameter, both motives, all five minors, and the (empty) result
+indices; argument arities count parameters plus constructor fields. -/
+theorem treeRulePattern_inventory :
+    TreeGen.flatCtors.map (fun c => TreeGen.rulePattern c) =
+      [.iota (.str ``Tree "rec") 8 ``Tree.leaf 2,
+       .iota (.str ``Tree "rec") 8 ``Tree.node 2,
+       .iota (.str ``Tree "rec") 8 ``Tree.branch 2,
+       .iota (.str ``TreeList "rec") 8 ``TreeList.nil 1,
+       .iota (.str ``TreeList "rec") 8 ``TreeList.cons 3] := by decide
+
+/-! ## D2 environment layer
+
+The block is added to `d1Env` by the four-phase block transaction.  Its
+semantic package is the empty-environment package re-based by monotonicity:
+`BlockGenerationChecked.WF` is monotone in every field except the staging
+equation, which is re-established over `d1Env` directly. -/
+
+local instance : Inhabited VEnv := ⟨VEnv.empty⟩
+
+theorem tree_fresh : d1Env.constants ``Tree = none := by native_decide
+
+theorem treeList_fresh : d1Env.constants ``TreeList = none := by native_decide
+
+theorem tree_name_ne_treeList : (``Tree : Name) ≠ ``TreeList := by decide
+
+/-- The environment after the block's family constants, before any
+constructor. -/
+def d2StageT := (d1Env.addConst ``Tree treeType.toVConstant).get!
+
+def d2BlockEnv := (d2StageT.addConst ``TreeList treeListType.toVConstant).get!
+
+theorem d1Env_add_tree :
+    d1Env.addConst ``Tree treeType.toVConstant = some d2StageT := by
+  simp [VEnv.addConst, tree_fresh, d2StageT]
+
+theorem treeList_fresh_T : d2StageT.constants ``TreeList = none := by
+  have hne := tree_name_ne_treeList
+  simp [d2StageT, VEnv.addConst, tree_fresh, hne, treeList_fresh]
+
+theorem d2StageT_add_treeList :
+    d2StageT.addConst ``TreeList treeListType.toVConstant =
+      some d2BlockEnv := by
+  simp [VEnv.addConst, treeList_fresh_T, d2BlockEnv]
+
+theorem d1Env_stage :
+    d1Env.stageInductiveTypes treeDecl.types = some d2BlockEnv := by
+  simp [VEnv.stageInductiveTypes, treeDecl, List.foldlM]
+  exact ⟨_, d1Env_add_tree, d2StageT_add_treeList⟩
+
+theorem d1Env_le_d2BlockEnv : d1Env ≤ d2BlockEnv :=
+  (VEnv.addConst_le d1Env_add_tree).trans
+    (VEnv.addConst_le d2StageT_add_treeList)
+
+/-! ### Re-basing the block's semantic package
+
+`treeBlockGenerationWF` lives over `VEnv.empty`/`treeBlockEnv`.  Every field
+except the staging equation is monotone, so the D2 package follows from two
+environment inclusions. -/
+
+theorem empty_le_d1Env : VEnv.empty ≤ d1Env where
+  constants h := by simp [VEnv.empty] at h
+  defeqs h := h.elim
+  structEtas h := h.elim
+
+/-- Adding the same constant to a larger environment stays larger. -/
+theorem addConst_le_of_le {e₁ e₂ s₁ s₂ : VEnv} {n : Name} {ci : VConstant}
+    (h₁ : e₁.addConst n ci = some s₁) (h₂ : e₂.addConst n ci = some s₂)
+    (hle : e₁ ≤ e₂) : s₁ ≤ s₂ := by
+  unfold VEnv.addConst at h₁ h₂
+  split at h₁
+  · cases h₁
+  split at h₂
+  · cases h₂
+  cases h₁
+  cases h₂
+  constructor
+  · intro n' a h
+    have h' : (if n = n' then some ci else e₁.constants n') = some a := h
+    show (if n = n' then some ci else e₂.constants n') = some a
+    by_cases hn : n = n'
+    · rw [if_pos hn] at h' ⊢
+      exact h'
+    · rw [if_neg hn] at h' ⊢
+      exact hle.constants h'
+  · exact fun h => hle.defeqs h
+  · exact fun h => hle.structEtas h
+
+/-- Staging the same family list over a larger environment stays larger. -/
+theorem stageInductiveTypes_le_of_le :
+    ∀ (types : List VInductiveType) {e₁ e₂ s₁ s₂ : VEnv},
+      e₁.stageInductiveTypes types = some s₁ →
+      e₂.stageInductiveTypes types = some s₂ →
+      e₁ ≤ e₂ → s₁ ≤ s₂
+  | [], _, _, _, _, h₁, h₂, hle => by
+    cases h₁; cases h₂; exact hle
+  | ty :: types, e₁, e₂, s₁, s₂, h₁, h₂, hle => by
+    rw [VEnv.stageInductiveTypes, List.foldlM_cons] at h₁ h₂
+    rcases Option.bind_eq_some_iff.1 h₁ with ⟨t₁, ht₁, hrest₁⟩
+    rcases Option.bind_eq_some_iff.1 h₂ with ⟨t₂, ht₂, hrest₂⟩
+    exact stageInductiveTypes_le_of_le types hrest₁ hrest₂
+      (addConst_le_of_le ht₁ ht₂ hle)
+
+/-- Pointwise strengthening of a `Forall₂` witness. -/
+theorem forall₂_imp {α β : Type _} {R S : α → β → Prop}
+    (H : ∀ a b, R a b → S a b) :
+    ∀ {l₁ : List α} {l₂ : List β},
+      List.Forall₂ R l₁ l₂ → List.Forall₂ S l₁ l₂
+  | _, _, .nil => .nil
+  | _, _, .cons h t => .cons (H _ _ h) (forall₂_imp H t)
+
+theorem treeBlockEnv_le_d2BlockEnv : treeBlockEnv ≤ d2BlockEnv :=
+  stageInductiveTypes_le_of_le treeDecl.types treeStage d1Env_stage
+    empty_le_d1Env
+
+/-- The block's semantic package, re-based from the empty environment onto
+`d1Env`.  Only the staging equation is genuinely new; every other field is
+the empty-environment field transported by monotonicity. -/
+theorem d2BlockGenerationWF : TreeGen.WF d1Env d2BlockEnv where
+  blockWF :=
+    ⟨⟨d1Env_stage,
+      forall₂_imp
+        (fun _ _ h =>
+          ⟨VEnv.IsDefEqU.mono empty_le_d1Env h.1,
+            forall₂_imp
+              (fun _ _ hc => VEnv.IsDefEqU.mono treeBlockEnv_le_d2BlockEnv hc)
+              h.2⟩)
+        treeNormalizationBlockWF.2⟩,
+      VInductDecl.CheckedBlock.WF.mono empty_le_d1Env
+        treeBlockGenerationWF.blockWF.2⟩
+  resultLevelWF := treeBlockGenerationWF.resultLevelWF
+  paramsTel := VEnv.TelDefEq.mono empty_le_d1Env treeBlockGenerationWF.paramsTel
+  families := fun family hfamily =>
+    VInductDecl.NormalizedFamily.WF.mono empty_le_d1Env
+      (treeBlockGenerationWF.families family hfamily)
+  constructors := fun constructor hconstructor =>
+    VInductDecl.NormalizedBlockCtor.WF.mono treeBlockEnv_le_d2BlockEnv
+      (treeBlockGenerationWF.constructors constructor hconstructor)
+
+/-! ### The completed block transaction -/
+
+theorem d2Env_isSome : (d1Env.addInductBlockGeneration TreeGen).isSome := by
+  native_decide
+
+/-- The complete D2 environment: the D1 environment followed by one checked
+mutual inductive block declaration. -/
+def d2Env : VEnv := (d1Env.addInductBlockGeneration TreeGen).get d2Env_isSome
+
+theorem d1Env_addBlock :
+    d1Env.addInductBlockGeneration TreeGen = some d2Env :=
+  (Option.some_get d2Env_isSome).symm
+
+theorem d2Env_ordered : d2Env.Ordered :=
+  VEnv.addInductBlockGeneration_WF d1Env_ordered d2BlockGenerationWF
+    d1Env_addBlock
+
+/-- The block is a genuine declaration history step. -/
+theorem d2Env_step : VDecl.WF d1Env (.induct treeDecl) d2Env :=
+  .inductBlock d2BlockGenerationWF d1Env_addBlock
+
+theorem d2Env_wf : d2Env.WF := by
+  obtain ⟨ds, hds⟩ := d1Env_wf
+  exact ⟨.induct treeDecl :: ds, .decl d2Env_step hds⟩
+
+theorem d2Trace :
+    Nonempty (VEnv.AddInductBlockGenerationTrace d1Env d2Env TreeGen) :=
+  VEnv.addInductBlockGeneration_trace d1Env_addBlock
+
+theorem d1Env_le_d2Env : d1Env ≤ d2Env := by
+  obtain ⟨trace⟩ := d2Trace
+  exact trace.le
+
+theorem d2Env_family_lookup {type : VInductiveType}
+    (htype : type ∈ treeDecl.types) :
+    d2Env.constants type.name = some type.toVConstant := by
+  obtain ⟨trace⟩ := d2Trace
+  exact trace.family_lookup htype
+
+theorem d2Env_ctor_lookup {constructor : VConstVal}
+    (hconstructor : constructor ∈ treeDecl.blockConstructorConstants) :
+    d2Env.constants constructor.name = some constructor.toVConstant := by
+  obtain ⟨trace⟩ := d2Trace
+  exact trace.ctor_lookup hconstructor
+
+theorem d2Env_rec_lookup {recursor : VConstVal}
+    (hrecursor : recursor ∈ TreeGen.recursors) :
+    d2Env.constants recursor.name = some recursor.toVConstant := by
+  obtain ⟨trace⟩ := d2Trace
+  exact trace.rec_lookup hrecursor
+
+theorem d2Env_rule_mem {rule : VDefEq}
+    (hrule : rule ∈ TreeGen.generatedRules) : d2Env.defeqs rule := by
+  obtain ⟨trace⟩ := d2Trace
+  exact trace.rule_mem hrule
+
+/-- The registered defeqs of the block-extended environment, inverted
+exactly: a generated block rule or an inherited D1 rule.  This is the landed
+`addInductBlockGeneration_defeqs` instantiated at the live fixture. -/
+theorem d2Env_defeqs_iff (df : VDefEq) :
+    d2Env.defeqs df ↔ df ∈ TreeGen.generatedRules ∨ d1Env.defeqs df :=
+  TreeGen.addInductBlockGeneration_defeqs d1Env_addBlock df
+
+/-! ### Structure-eta transparency of the transaction
+
+Neither phase of the block transaction touches the structure-eta registry. -/
+
+theorem addConst_structEtas {env env' : VEnv} {n : Name} {ci : VConstant}
+    (h : env.addConst n ci = some env') {rule : VStructEta} :
+    env'.structEtas rule ↔ env.structEtas rule := by
+  unfold VEnv.addConst at h
+  split at h
+  · cases h
+  · cases h
+    exact Iff.rfl
+
+theorem foldlM_addConst_structEtas {α : Type _} (name : α → Name)
+    (ci : α → VConstant) :
+    ∀ (xs : List α) {env env' : VEnv},
+      xs.foldlM (fun env x => env.addConst (name x) (ci x)) env = some env' →
+      ∀ {rule : VStructEta}, (env'.structEtas rule ↔ env.structEtas rule)
+  | [], _, _, h, _ => by cases h; exact Iff.rfl
+  | x :: xs, _, _, h, _ => by
+    rw [List.foldlM_cons] at h
+    rcases Option.bind_eq_some_iff.1 h with ⟨envx, hx, hrest⟩
+    exact (foldlM_addConst_structEtas name ci xs hrest).trans
+      (addConst_structEtas hx)
+
+theorem foldl_addDefEq_structEtas :
+    ∀ (dfs : List VDefEq) (env : VEnv) (rule : VStructEta),
+      ((dfs.foldl VEnv.addDefEq env).structEtas rule ↔ env.structEtas rule)
+  | [], _, _ => Iff.rfl
+  | d :: dfs, env, rule =>
+    (foldl_addDefEq_structEtas dfs (env.addDefEq d) rule).trans Iff.rfl
+
+theorem d2Env_no_structEta (rule : VStructEta) : ¬d2Env.structEtas rule := by
+  obtain ⟨trace⟩ := d2Trace
+  intro h
+  rw [← trace.addRules, foldl_addDefEq_structEtas] at h
+  rw [foldlM_addConst_structEtas _ _ _ trace.addRecs,
+    foldlM_addConst_structEtas _ _ _ trace.addCtors,
+    foldlM_addConst_structEtas _ _ _ trace.addTypes] at h
+  exact d1Env_no_structEta rule h
+
+/-! ## D2 pattern layer
+
+The block's own five iota rules are the `.rule` half of `AssembledPat`; they
+must *not* appear in the `exts` list, whose members are required to be head
+separated from every block rule.  The genuinely external extensions are the
+three zero-universe definition rules inherited from D1. -/
+
+/-- The `d0def` unfolding rule as a certified extension.  Its registered
+tower is a bare constant, so the beta-collapsed match is the constant
+pattern itself. -/
+def d0DefExt : CertifiedExtension where
+  df := d0DefVal.toDefEq
+  pat := .defn d0DefVal.name
+  rhs := .fixed d0DefVal.value d0DefClosed
+  check := .true
+  covers := fun _ _ => ⟨_, _, .const⟩
+
+def d1MutAExt : CertifiedExtension where
+  df := d1MutAVal.toDefEq
+  pat := .defn d1MutAVal.name
+  rhs := .fixed d1MutAVal.value d1MutAClosed
+  check := .true
+  covers := fun _ _ => ⟨_, _, .const⟩
+
+def d1MutBExt : CertifiedExtension where
+  df := d1MutBVal.toDefEq
+  pat := .defn d1MutBVal.name
+  rhs := .fixed d1MutBVal.value d1MutBClosed
+  check := .true
+  covers := fun _ _ => ⟨_, _, .const⟩
+
+/-- The external extension list of the D2 assembly: exactly the D1
+definition rules. -/
+def d2Exts : List CertifiedExtension := [d0DefExt, d1MutAExt, d1MutBExt]
+
+/-- Head separation of a definition extension from a generated iota rule.
+The constructor-side obligation is vacuous: a `defn` pattern has no
+constructor head. -/
+theorem headSep_defn_iota {n R C : Name} {m k : Nat}
+    (h1 : n ≠ R) (h2 : n ≠ C) :
+    (SimplePattern.defn n).HeadSep (.iota R m C k) where
+  symb_ne_symb := h1
+  symb_ne_ctor := fun c hc => by cases hc; exact h2
+  ctor_ne_symb := fun c hc => by simp at hc
+
+/-- Head separation of two distinct definition extensions. -/
+theorem headSep_defn_defn {n n' : Name} (h : n ≠ n') :
+    (SimplePattern.defn n).HeadSep (.defn n') where
+  symb_ne_symb := h
+  symb_ne_ctor := fun c hc => by simp at hc
+  ctor_ne_symb := fun c hc => by simp at hc
+
+/-- Every D1 definition head is head separated from every rule of the
+block. -/
+theorem d2Ext_headSep_tree {n : Name}
+    (h1 : n ≠ .str ``Tree "rec") (h2 : n ≠ .str ``TreeList "rec")
+    (h3 : n ≠ ``Tree.leaf) (h4 : n ≠ ``Tree.node) (h5 : n ≠ ``Tree.branch)
+    (h6 : n ≠ ``TreeList.nil) (h7 : n ≠ ``TreeList.cons)
+    {constructor : NormalizedBlockCtor} (hc : constructor ∈ TreeGen.flatCtors) :
+    (SimplePattern.defn n).HeadSep (TreeGen.rulePattern constructor) := by
+  have hp : TreeGen.rulePattern constructor ∈
+      TreeGen.flatCtors.map (fun c => TreeGen.rulePattern c) :=
+    List.mem_map_of_mem hc
+  rw [treeRulePattern_inventory] at hp
+  simp only [List.mem_cons, List.not_mem_nil, or_false] at hp
+  rcases hp with hp | hp | hp | hp | hp <;> rw [hp]
+  · exact headSep_defn_iota h1 h3
+  · exact headSep_defn_iota h1 h4
+  · exact headSep_defn_iota h1 h5
+  · exact headSep_defn_iota h2 h6
+  · exact headSep_defn_iota h2 h7
+
+/-- The complete separation certificate for the D2 assembly: the block's
+five generated rules unioned with the three inherited definition rules.
+Every obligation is a literal name comparison, discharged by kernel
+`decide`. -/
+theorem d2ExtSeparation : TreeGen.ExtSeparation d2Exts := by
+  refine ⟨?_, ?_, ?_, ?_⟩
+  · rintro ext hm
+    simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hm
+    rcases hm with rfl | rfl | rfl <;> exact trivial
+  · rintro ext hm c hc
+    simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hm
+    rcases hm with rfl | rfl | rfl <;>
+      exact d2Ext_headSep_tree (by decide) (by decide)
+        (by decide) (by decide) (by decide) (by decide) (by decide) hc
+  · rintro e1 h1 e2 h2 hpat
+    simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at h1 h2
+    rcases h1 with rfl | rfl | rfl <;> rcases h2 with rfl | rfl | rfl <;>
+      first
+        | rfl
+        | exact absurd hpat (by decide)
+  · rintro e1 h1 e2 h2 hne
+    simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at h1 h2
+    rcases h1 with rfl | rfl | rfl <;> rcases h2 with rfl | rfl | rfl <;>
+      first
+        | exact absurd rfl hne
+        | exact headSep_defn_defn (by decide)
+
+/-- The complete D2 pattern inventory: the generated `Nat` rules inherited
+from D0, and the assembled union of the new block's five generated rules
+with the three inherited definition rules. -/
+inductive D2Pat : (p : Pattern) → p.RHS × p.Check → Prop where
+  | nat {p : Pattern} {r : p.RHS × p.Check} : NatPat p r → D2Pat p r
+  | assembled {p : Pattern} {r : p.RHS × p.Check} :
+      TreeGen.AssembledPat treeRuleClosure d2Exts p r → D2Pat p r
+
+/-- Transport the complete D1 inventory into D2: the `Nat` rules stay
+`IotaPat` members, and the three definition rules become extension members
+of the assembly.  The payloads are literally the same terms. -/
+theorem d1Pat_to_d2 {p : Pattern} {r : p.RHS × p.Check}
+    (H : D1Pat p r) : D2Pat p r := by
+  cases H with
+  | old H =>
+    cases H with
+    | iota H => exact .nat H
+    | defn =>
+      exact .assembled (.ext d0DefExt (by simp [d2Exts]))
+  | defnA => exact .assembled (.ext d1MutAExt (by simp [d2Exts]))
+  | defnB => exact .assembled (.ext d1MutBExt (by simp [d2Exts]))
+
+/-! ### Simple-pattern inventories and cross-block separation -/
+
+def d2NatPatterns : List SimplePattern :=
+  [.iota ``Nat.rec 3 ``Nat.zero 0, .iota ``Nat.rec 3 ``Nat.succ 1]
+
+def d2AssembledPatterns : List SimplePattern :=
+  [.iota (.str ``Tree "rec") 8 ``Tree.leaf 2,
+   .iota (.str ``Tree "rec") 8 ``Tree.node 2,
+   .iota (.str ``Tree "rec") 8 ``Tree.branch 2,
+   .iota (.str ``TreeList "rec") 8 ``TreeList.nil 1,
+   .iota (.str ``TreeList "rec") 8 ``TreeList.cons 3,
+   .defn d0DefVal.name, .defn d1MutAVal.name, .defn d1MutBVal.name]
+
+theorem natPat_inventory {p : Pattern} {r : p.RHS × p.Check} (H : NatPat p r) :
+    ∃ sp ∈ d2NatPatterns, p = sp.toPattern := by
+  rcases natPat_pattern H with hp | hp
+  · exact ⟨_, by simp [d2NatPatterns], hp⟩
+  · exact ⟨_, by simp [d2NatPatterns], hp⟩
+
+theorem assembledPat_inventory {p : Pattern} {r : p.RHS × p.Check}
+    (H : TreeGen.AssembledPat treeRuleClosure d2Exts p r) :
+    ∃ sp ∈ d2AssembledPatterns, p = sp.toPattern := by
+  cases H with
+  | rule h =>
+    cases h with
+    | @mk i c hentry =>
+      have hp : TreeGen.rulePattern c ∈
+          TreeGen.flatCtors.map (fun c => TreeGen.rulePattern c) :=
+        List.mem_map_of_mem (List.mem_of_getElem? hentry)
+      rw [treeRulePattern_inventory] at hp
+      simp only [List.mem_cons, List.not_mem_nil, or_false] at hp
+      refine ⟨TreeGen.rulePattern c, ?_, rfl⟩
+      rcases hp with hp | hp | hp | hp | hp <;> rw [hp] <;>
+        simp [d2AssembledPatterns]
+  | ext ext hmem =>
+    refine ⟨ext.pat, ?_, rfl⟩
+    simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+    rcases hmem with rfl | rfl | rfl <;> simp [d2AssembledPatterns,
+      d0DefExt, d1MutAExt, d1MutBExt]
+
+/-- Cross-block head separation: every `Nat` rule pattern is head separated
+from every member of the assembly. -/
+theorem d2Nat_headSep_assembled {spn spa : SimplePattern}
+    (hn : spn ∈ d2NatPatterns) (ha : spa ∈ d2AssembledPatterns) :
+    spn.HeadSep spa := by
+  simp only [d2NatPatterns, d2AssembledPatterns, List.mem_cons,
+    List.not_mem_nil, or_false] at hn ha
+  rcases hn with rfl | rfl <;>
+    rcases ha with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl <;>
+    first
+      | exact SimplePattern.HeadSep.iota_iota (by decide) (by decide)
+          (by decide)
+      | exact (headSep_defn_iota (by decide) (by decide)).symm
+
+/-! ### The four `Params` non-overlap obligations
+
+The same-block cases delegate to the landed laws: `IotaPat.pat_uniq` for the
+`Nat` block and `AssembledPat.pat_uniq` (etc.) for the assembly.  Only the
+*cross-block* cases are proved here, from the landed cross-term engine
+`SimplePattern.HeadSep.inter_subpattern_none` and the two shape lemmas
+below, which mirror the corresponding inlined cases of the landed union
+proofs. -/
+
+/-- Cross-block `pat_app_l_uniq`, for two head-separated simple patterns.
+This is the inlined `(rule, ext)` case of `AssembledPat.pat_app_l_uniq`,
+restated for two arbitrary head-separated simple patterns. -/
+theorem simple_app_l_uniq {sp sp' : SimplePattern} {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (hsep : sp.HeadSep sp')
+    (h : Subpattern (.app p₁ p₂) sp.toPattern)
+    (h' : Subpattern (.app p₁' p₂') sp'.toPattern)
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases sp with
+  | defn n => exact absurd (Subpattern.const_inv h) (by simp)
+  | iota R m C k =>
+    obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+    obtain ⟨j, -, rfl⟩ := Subpattern.var_varN_const_le h₃
+    cases sp' with
+    | defn n' => exact absurd (Subpattern.const_inv h') (by simp)
+    | iota R' m' C' k' =>
+      obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h'
+      exact Pattern.varN_const_inter_of_ne_name
+        hsep.symb_ne_symb.symm _ _
+
+/-- Cross-block `pat_app_uniq`, for two head-separated simple patterns. -/
+theorem simple_app_uniq {sp sp' : SimplePattern}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (hsep : sp.HeadSep sp')
+    (h : Subpattern (.app p₁ p₂) sp.toPattern)
+    (h' : Subpattern (.app p₁' p₂') sp'.toPattern)
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases sp with
+  | defn n => exact absurd (Subpattern.const_inv h) (by simp)
+  | iota R m C k =>
+    obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+    obtain ⟨j, -, rfl⟩ := h₃.varN_const_le
+    cases sp' with
+    | defn n' => exact absurd (Subpattern.const_inv h') (by simp)
+    | iota R' m' C' k' =>
+      obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h'
+      obtain ⟨j', -, rfl⟩ := h₃'.varN_const_le
+      exact Pattern.varN_const_inter_of_ne_name
+        (hsep.symb_ne_ctor C' rfl) _ _
+
+theorem d2Pat_simple {p : Pattern} {r : p.RHS × p.Check}
+    (H : D2Pat p r) : ∃ sp : SimplePattern, p = sp.toPattern := by
+  cases H with
+  | nat H =>
+    exact VInductDecl.BlockGenerationChecked.IotaPat.pat_simple NatGeneration H
+  | assembled H =>
+    exact VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple TreeGen H
+
+theorem d2Pat_uniq {p₁ p₂ p₃ p₄ : Pattern}
+    {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check}
+    (H1 : D2Pat p₁ r) (H2 : D2Pat p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by
+  cases H1 with
+  | nat H1 =>
+    cases H2 with
+    | nat H2 =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+        H1 H2 H3 H4
+    | assembled H2 =>
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H1
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H2
+      rw [(d2Nat_headSep_assembled hn ha).inter_subpattern_none H3] at H4
+      cases H4
+  | assembled H1 =>
+    cases H2 with
+    | nat H2 =>
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H1
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H2
+      rw [((d2Nat_headSep_assembled hn ha).symm).inter_subpattern_none H3]
+        at H4
+      cases H4
+    | assembled H2 =>
+      exact VInductDecl.BlockGenerationChecked.AssembledPat.pat_uniq TreeGen
+        d2ExtSeparation H1 H2 H3 H4
+
+theorem d2Pat_app_l {p : Pattern} {r : p.RHS × p.Check}
+    {p₁ p₂ p₃ p₄ : Pattern}
+    (H : D2Pat p r) (h : Subpattern (.app p₁ p₂) p) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  obtain ⟨sp, rfl⟩ := d2Pat_simple H
+  exact SimplePattern.toPattern_app_l h
+
+theorem d2Pat_app_l_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : D2Pat p r) (H' : D2Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases H with
+  | nat H =>
+    cases H' with
+    | nat H' =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq
+        NatGeneration H H' h h' h₃
+    | assembled H' =>
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H'
+      exact simple_app_l_uniq (d2Nat_headSep_assembled hn ha) h h' h₃
+  | assembled H =>
+    cases H' with
+    | nat H' =>
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H'
+      exact simple_app_l_uniq ((d2Nat_headSep_assembled hn ha).symm) h h' h₃
+    | assembled H' =>
+      exact VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_l_uniq
+        TreeGen d2ExtSeparation H H' h h' h₃
+
+theorem d2Pat_app_uniq {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : D2Pat p r) (H' : D2Pat p' r')
+    (h : Subpattern (.app p₁ p₂) p)
+    (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases H with
+  | nat H =>
+    cases H' with
+    | nat H' =>
+      exact VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq
+        NatGeneration H H' h h' h₃ h₃'
+    | assembled H' =>
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H'
+      exact simple_app_uniq (d2Nat_headSep_assembled hn ha) h h' h₃ h₃'
+  | assembled H =>
+    cases H' with
+    | nat H' =>
+      obtain ⟨spa, ha, rfl⟩ := assembledPat_inventory H
+      obtain ⟨spn, hn, rfl⟩ := natPat_inventory H'
+      exact simple_app_uniq ((d2Nat_headSep_assembled hn ha).symm) h h' h₃ h₃'
+    | assembled H' =>
+      exact VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_uniq
+        TreeGen d2ExtSeparation H H' h h' h₃ h₃'
+
+/-! ### The classification table
+
+The block contributes two family heads, five constructor heads, and two
+recursor heads.  Major arity 8 (one parameter, two motives, five minors, no
+indices) gives each recursor the symbol arity 9 demanded by `Pattern.WF` at
+the top of an iota pattern. -/
+
+def d2Classify (n : Name) : Option Classification :=
+  if n = ``Tree then some (.indTy 1)
+  else if n = ``TreeList then some (.indTy 1)
+  else if n = ``Tree.leaf then some (.ctor 2)
+  else if n = ``Tree.node then some (.ctor 2)
+  else if n = ``Tree.branch then some (.ctor 2)
+  else if n = ``TreeList.nil then some (.ctor 1)
+  else if n = ``TreeList.cons then some (.ctor 3)
+  else if n = .str ``Tree "rec" then some (.symb 9)
+  else if n = .str ``TreeList "rec" then some (.symb 9)
+  else d1Classify n
+
+/-- The D1 table is the restriction of the D2 table: every name it
+classifies is distinct from all nine block heads. -/
+theorem d1Classify_agrees {c : Name} {cl : Classification}
+    (H : d1Classify c = some cl) : d2Classify c = some cl := by
+  have hcases : c = d1MutAVal.name ∨ c = d1MutBVal.name ∨
+      c = d0DefVal.name ∨ c = ``Nat ∨ c = ``Nat.zero ∨ c = ``Nat.succ ∨
+      c = ``Nat.rec := by
+    by_cases h1 : c = d1MutAVal.name
+    · exact .inl h1
+    by_cases h2 : c = d1MutBVal.name
+    · exact .inr (.inl h2)
+    by_cases h3 : c = d0DefVal.name
+    · exact .inr (.inr (.inl h3))
+    by_cases h4 : c = ``Nat
+    · exact .inr (.inr (.inr (.inl h4)))
+    by_cases h5 : c = ``Nat.zero
+    · exact .inr (.inr (.inr (.inr (.inl h5))))
+    by_cases h6 : c = ``Nat.succ
+    · exact .inr (.inr (.inr (.inr (.inr (.inl h6)))))
+    by_cases h7 : c = ``Nat.rec
+    · exact .inr (.inr (.inr (.inr (.inr (.inr h7)))))
+    simp [d1Classify, d0Classify, natClassify, h1, h2, h3, h4, h5, h6,
+      h7] at H
+  rcases hcases with rfl | rfl | rfl | rfl | rfl | rfl | rfl <;>
+    simpa [d2Classify, d0DefVal, d1MutAVal, d1MutBVal] using H
+
+theorem d1PatWF_lift {p : Pattern} {top : Bool} {extra : Nat}
+    (H : p.WF d1Classify top extra) : p.WF d2Classify top extra := by
+  induction p generalizing top extra with
+  | const c => exact d1Classify_agrees H
+  | var f ih => exact ih H
+  | app f a ihf iha => exact ⟨ihf H.1, iha H.2⟩
+
+theorem d2Pat_wf {p : Pattern} {r : p.RHS × p.Check}
+    (H : D2Pat p r) : p.WF d2Classify := by
+  cases H with
+  | nat H => exact d1PatWF_lift (d1Pat_wf (.old (.iota H)))
+  | assembled H =>
+    cases H with
+    | rule h =>
+      cases h with
+      | @mk i c hentry =>
+        have hp : TreeGen.rulePattern c ∈
+            TreeGen.flatCtors.map (fun c => TreeGen.rulePattern c) :=
+          List.mem_map_of_mem (List.mem_of_getElem? hentry)
+        rw [treeRulePattern_inventory] at hp
+        simp only [List.mem_cons, List.not_mem_nil, or_false] at hp
+        show ((TreeGen.rulePattern c).toPattern).WF d2Classify
+        rcases hp with hp | hp | hp | hp | hp <;> rw [hp] <;>
+          simp [SimplePattern.toPattern, Pattern.varN, Pattern.WF, d2Classify]
+    | ext ext hmem =>
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl
+      · exact d1PatWF_lift (d1Pat_wf (.old .defn))
+      · exact d1PatWF_lift (d1Pat_wf .defnA)
+      · exact d1PatWF_lift (d1Pat_wf .defnB)
+
+/-- The complete D2 structural instance: the D1 inventory extended by a live
+mutual inductive block, over the block-extended environment. -/
+def d2Params (univs : Nat) : Params where
+  env := d2Env
+  henv := d2Env_ordered
+  univs := univs
+  Pat := D2Pat
+  classify := d2Classify
+  pat_simple := d2Pat_simple
+  pat_wf := d2Pat_wf
+  pat_uniq := d2Pat_uniq
+  pat_app_l := d2Pat_app_l
+  pat_app_l_uniq := d2Pat_app_l_uniq
+  pat_app_uniq := d2Pat_app_uniq
+
+/-! ## Semantic-layer fragments
+
+`Params.StructureEtaSound` and `Params.Semantic.iotaRule` are the two
+semantic obligations that are purely registry-level: neither needs a typed
+reduction site.  They are delivered here for the complete inventory. -/
+
+theorem d2StructureEtaSound (univs : Nat) :
+    @Params.StructureEtaSound (d2Params univs) := by
+  letI : Params := d2Params univs
+  intro rule levels Gamma params major hreg
+  exact (d2Env_no_structEta rule hreg).elim
+
+/-- Every generated rule of the block is registered in `d2Env`. -/
+theorem treeRule_registered {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some constructor) :
+    d2Env.defeqs (TreeGen.rule i constructor) := by
+  refine d2Env_rule_mem ?_
+  have : (constructor, i) ∈ TreeGen.flatCtors.zipIdx := by
+    apply List.mem_of_getElem? (i := i)
+    rw [List.getElem?_zipIdx, hentry, Option.map_some, Nat.zero_add]
+  simpa only [VInductDecl.BlockGenerationChecked.generatedRules,
+    List.mem_map] using ⟨_, this, rfl⟩
+
+/-- The RHS template of a block rule is the registered right tower applied
+to the ordered capture list. -/
+theorem treeRuleRHS_tower {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some constructor) :
+    TreeGen.ruleRHS treeRuleClosure hentry =
+      Pattern.RHS.appN
+        (.fixed (TreeGen.rule i constructor).rhs
+          (treeRuleClosure.rhs_closed hentry))
+        (TreeGen.captureArgs constructor) := rfl
+
+/-- The ordered capture inventory of one block rule: the recursor side's
+parameter, motives, and minors, then the constructor's fields. -/
+def treeCapturePaths (constructor : NormalizedBlockCtor) :
+    List (((TreeGen.rulePattern constructor).toPattern).Path) :=
+  ((Pattern.varNPaths (.const (TreeGen.ruleRecName constructor))
+      (TreeGen.ruleMajorArity constructor)).take
+    (treeDecl.nparams + TreeGen.familyCount + TreeGen.minorCount)).map Sum.inl ++
+  ((Pattern.varNPaths (.const constructor.ctor.raw.name)
+      (TreeGen.ruleArgArity constructor)).drop treeDecl.nparams).map Sum.inr
+
+theorem treeCapturePaths_map_var (constructor : NormalizedBlockCtor) :
+    (treeCapturePaths constructor).map (fun path => .var path) =
+      TreeGen.captureArgs constructor := by
+  simp [treeCapturePaths, VInductDecl.BlockGenerationChecked.captureArgs,
+    List.map_map, Function.comp_def]
+
+/-- The `Pattern.IotaRule.rhsTower` shape for a block rule: the registered
+right tower applied to the ordered capture path list. -/
+theorem treeRuleRHS_capture_tower {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some constructor) :
+    TreeGen.ruleRHS treeRuleClosure hentry =
+      Pattern.RHS.appN
+        (.fixed (TreeGen.rule i constructor).rhs
+          (treeRuleClosure.rhs_closed hentry))
+        ((treeCapturePaths constructor).map fun path => .var path) :=
+  (treeRuleRHS_tower hentry).trans (by rw [treeCapturePaths_map_var])
+
+/-- Inversion for the assembly at a *variable* pattern.  `cases` cannot be
+used at a concrete iota pattern — the block half's index
+`(rulePattern c).toPattern` is a stuck `varN` tower — so this is the
+`AssembledPat` counterpart of `IotaPat.recover`. -/
+theorem assembledPat_cases {p : Pattern} {r : p.RHS × p.Check}
+    (H : TreeGen.AssembledPat treeRuleClosure d2Exts p r) :
+    (∃ (i : Nat) (c : NormalizedBlockCtor)
+        (h : TreeGen.flatCtors[i]? = some c),
+        p = (TreeGen.rulePattern c).toPattern ∧
+          r ≍ (TreeGen.ruleRHS treeRuleClosure h,
+            TreeGen.ruleCheck treeRuleClosure (List.mem_of_getElem? h))) ∨
+      (∃ ext ∈ d2Exts, p = ext.pat.toPattern) := by
+  cases H with
+  | rule h =>
+    cases h with
+    | @mk i c hentry => exact .inl ⟨i, c, hentry, rfl, HEq.rfl⟩
+  | ext ext hmem => exact .inr ⟨ext, hmem, rfl⟩
+
+/-- `Params.Semantic.iotaRule` for the complete D2 inventory: every iota
+pattern in `Pat` recovers its unique registered tower and ordered capture
+inventory.  This field is purely registry-level — it needs no typed
+reduction site — and is therefore delivered for both blocks. -/
+theorem d2IotaRule_nonempty (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d2Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    Nonempty (@Pattern.IotaRule (d2Params univs) rec major ctor arity r) := by
+  letI : Params := d2Params univs
+  change D2Pat _ _ at H
+  cases H with
+  | nat H =>
+    let oldRule := d1IotaRule univs (D1Pat.old (D0Pat.iota H))
+    rcases oldRule with
+      ⟨oldPat, df, registered, rhsClosed, capturePaths, rhsTower⟩
+    exact ⟨{
+      pat := D2Pat.nat H
+      df := df
+      registered := d1Env_le_d2Env.defeqs registered
+      rhsClosed := rhsClosed
+      capturePaths := capturePaths
+      rhsTower := rhsTower }⟩
+  | assembled H =>
+    rcases assembledPat_cases H with
+      ⟨i, c, hentry, hpattern, hr⟩ | ⟨ext, hmem, hpattern⟩
+    · change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (TreeGen.ruleRecName c)
+          (TreeGen.ruleMajorArity c) c.ctor.raw.name
+          (TreeGen.ruleArgArity c) at hpattern
+      obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+      obtain rfl : r = _ := eq_of_heq hr
+      exact ⟨{
+        pat := D2Pat.assembled (.rule (.mk hentry))
+        df := TreeGen.rule i c
+        registered := treeRule_registered hentry
+        rhsClosed := treeRuleClosure.rhs_closed hentry
+        capturePaths := treeCapturePaths c
+        rhsTower := treeRuleRHS_capture_tower hentry }⟩
+    · exfalso
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl <;>
+        exact absurd hpattern
+          (by simp [RecursorIotaPattern, d0DefExt, d1MutAExt, d1MutBExt])
+
+noncomputable def d2IotaRule (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : (d2Params univs).Pat
+      (RecursorIotaPattern rec major ctor arity) r) :
+    @Pattern.IotaRule (d2Params univs) rec major ctor arity r :=
+  Classical.choice (d2IotaRule_nonempty univs H)
+
+/-- Transport an inherited D1 iota descriptor into D2.  The syntax and
+payload indices are unchanged; only pattern membership and registration are
+weakened along the live environment extension. -/
+def d1IotaRuleToD2 (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : @Pattern.IotaRule (d1Params univs) rec major ctor arity r) :
+    @Pattern.IotaRule (d2Params univs) rec major ctor arity r := by
+  letI : Params := d1Params univs
+  rcases rule with
+    ⟨pat, df, registered, rhsClosed, capturePaths, rhsTower⟩
+  letI : Params := d2Params univs
+  exact {
+    pat := d1Pat_to_d2 pat
+    df := df
+    registered := d1Env_le_d2Env.defeqs registered
+    rhsClosed := rhsClosed
+    capturePaths := capturePaths
+    rhsTower := rhsTower }
+
+/-- The canonical D2 descriptor of an inherited Nat rule. -/
+noncomputable def d2NatIotaRule (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : NatPat (RecursorIotaPattern rec major ctor arity) r) :
+    @Pattern.IotaRule (d2Params univs) rec major ctor arity r :=
+  d1IotaRuleToD2 univs
+    (d1IotaRule univs (D1Pat.old (D0Pat.iota H)))
+
+/-- The fully explicit D2 descriptor of one Nat rule entry.  This variant
+is indexed by the generated-rule lookup rather than an abstract `NatPat`
+proof, so its registered equation and capture inventory compute directly. -/
+def d2NatEntryIotaRule (univs : Nat) {i : Nat}
+    {constructor : NormalizedBlockCtor}
+    (hentry : NatGeneration.flatCtors[i]? = some constructor) :
+    @Pattern.IotaRule (d2Params univs)
+      (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor)
+      (NatGeneration.ruleRHS natRuleClosure hentry,
+        NatGeneration.ruleCheck natRuleClosure
+          (List.mem_of_getElem? hentry)) := by
+  letI : Params := d2Params univs
+  exact {
+    pat := D2Pat.nat (.mk hentry)
+    df := NatGeneration.rule i constructor
+    registered := d1Env_le_d2Env.defeqs <|
+      d0Env_le_d1Env.defeqs <|
+        natFinalEnv_le_d0Env.defeqs (natRule_registered hentry)
+    rhsClosed := natRuleClosure.rhs_closed hentry
+    capturePaths := natCapturePaths constructor
+    rhsTower := natRuleRHS_tower hentry }
+
+/-- The canonical D2 descriptor of one generated Tree/TreeList rule. -/
+def d2TreeIotaRule (univs : Nat) {i : Nat}
+    {constructor : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some constructor) :
+    @Pattern.IotaRule (d2Params univs)
+      (TreeGen.ruleRecName constructor)
+      (TreeGen.ruleMajorArity constructor) constructor.ctor.raw.name
+      (TreeGen.ruleArgArity constructor)
+      (TreeGen.ruleRHS treeRuleClosure hentry,
+        TreeGen.ruleCheck treeRuleClosure (List.mem_of_getElem? hentry)) := by
+  letI : Params := d2Params univs
+  exact {
+    pat := D2Pat.assembled (.rule (.mk hentry))
+    df := TreeGen.rule i constructor
+    registered := treeRule_registered hentry
+    rhsClosed := treeRuleClosure.rhs_closed hentry
+    capturePaths := treeCapturePaths constructor
+    rhsTower := treeRuleRHS_capture_tower hentry }
+
+/-! ## D1-to-D2 proof transport
+
+`SExpr` retains its complete `Params` value as an inductive parameter, so
+crossing from the D1 instance into the block-extended D2 instance is an
+explicit syntax map.  Unlike D0/D1, the syntax layer is not hand-rolled: it
+is the generic univs-agreement transport of
+`Lean4Lean/Experimental/SExprTransport.lean` (R1), instantiated at the two
+instances.  Only the judgment transport below (`d1StrongToD2`) is
+rung-specific, because its `const`/`defn` cases consume the D2 pattern and
+classifier extensions. -/
+
+/-- The two instances agree on `univs` definitionally. -/
+abbrev d1d2 (univs : Nat) :
+    @Params.univs (d1Params univs) = @Params.univs (d2Params univs) := rfl
+
+/-! ### Freshness of the nine block heads over `d1Env` -/
+
+theorem treeLeaf_fresh : d1Env.constants ``Tree.leaf = none := by native_decide
+
+theorem treeNode_fresh : d1Env.constants ``Tree.node = none := by native_decide
+
+theorem treeBranch_fresh : d1Env.constants ``Tree.branch = none := by
+  native_decide
+
+theorem treeListNil_fresh : d1Env.constants ``TreeList.nil = none := by
+  native_decide
+
+theorem treeListCons_fresh : d1Env.constants ``TreeList.cons = none := by
+  native_decide
+
+theorem treeRec_fresh : d1Env.constants (.str ``Tree "rec") = none := by
+  native_decide
+
+theorem treeListRec_fresh : d1Env.constants (.str ``TreeList "rec") = none := by
+  native_decide
+
+/-! ### The nine block heads are unclassified by the D1 table -/
+
+theorem d1Classify_tree : d1Classify ``Tree = none := by native_decide
+
+theorem d1Classify_treeList : d1Classify ``TreeList = none := by native_decide
+
+theorem d1Classify_treeLeaf : d1Classify ``Tree.leaf = none := by native_decide
+
+theorem d1Classify_treeNode : d1Classify ``Tree.node = none := by native_decide
+
+theorem d1Classify_treeBranch : d1Classify ``Tree.branch = none := by
+  native_decide
+
+theorem d1Classify_treeListNil : d1Classify ``TreeList.nil = none := by
+  native_decide
+
+theorem d1Classify_treeListCons : d1Classify ``TreeList.cons = none := by
+  native_decide
+
+theorem d1Classify_treeRec : d1Classify (.str ``Tree "rec") = none := by
+  native_decide
+
+theorem d1Classify_treeListRec : d1Classify (.str ``TreeList "rec") = none := by
+  native_decide
+
+/-- A constant of the D1 environment is none of the nine block heads, so the
+D2 classifier restricts to the D1 classifier at it. -/
+theorem d2Classify_of_d1Const {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci) :
+    d2Classify c = d1Classify c := by
+  have h1 : c ≠ ``Tree := fun h => by rw [h, tree_fresh] at hreg; cases hreg
+  have h2 : c ≠ ``TreeList := fun h => by
+    rw [h, treeList_fresh] at hreg; cases hreg
+  have h3 : c ≠ ``Tree.leaf := fun h => by
+    rw [h, treeLeaf_fresh] at hreg; cases hreg
+  have h4 : c ≠ ``Tree.node := fun h => by
+    rw [h, treeNode_fresh] at hreg; cases hreg
+  have h5 : c ≠ ``Tree.branch := fun h => by
+    rw [h, treeBranch_fresh] at hreg; cases hreg
+  have h6 : c ≠ ``TreeList.nil := fun h => by
+    rw [h, treeListNil_fresh] at hreg; cases hreg
+  have h7 : c ≠ ``TreeList.cons := fun h => by
+    rw [h, treeListCons_fresh] at hreg; cases hreg
+  have h8 : c ≠ .str ``Tree "rec" := fun h => by
+    rw [h, treeRec_fresh] at hreg; cases hreg
+  have h9 : c ≠ .str ``TreeList "rec" := fun h => by
+    rw [h, treeListRec_fresh] at hreg; cases hreg
+  simp [d2Classify, h1, h2, h3, h4, h5, h6, h7, h8, h9]
+
+/-! ### Constant lookups of the block-extended environment restrict -/
+
+theorem foldlM_addConst_constants_old {α : Type _} (name : α → Name)
+    (ci : α → VConstant) {c : Name} :
+    ∀ (xs : List α) {env env' : VEnv},
+      xs.foldlM (fun env x => env.addConst (name x) (ci x)) env = some env' →
+      (∀ x ∈ xs, name x ≠ c) →
+      env'.constants c = env.constants c
+  | [], _, _, h, _ => by cases h; rfl
+  | x :: xs, _, _, h, hne => by
+    rw [List.foldlM_cons] at h
+    rcases Option.bind_eq_some_iff.1 h with ⟨envx, hx, hrest⟩
+    rw [foldlM_addConst_constants_old name ci xs hrest
+      (fun y hy => hne y (.tail _ hy))]
+    unfold VEnv.addConst at hx
+    split at hx
+    · cases hx
+    · cases hx
+      show (if name x = c then some (ci x) else _) = _
+      rw [if_neg (hne x (.head _))]
+
+theorem foldl_addDefEq_constants :
+    ∀ (dfs : List VDefEq) (env : VEnv) (c : Name),
+      (dfs.foldl VEnv.addDefEq env).constants c = env.constants c
+  | [], _, _ => rfl
+  | d :: dfs, env, c => foldl_addDefEq_constants dfs (env.addDefEq d) c
+
+theorem treeTypeConstants_names :
+    treeDecl.blockTypeConstants.map (·.name) = [``Tree, ``TreeList] := rfl
+
+theorem treeCtorConstants_names :
+    treeDecl.blockConstructorConstants.map (·.name) =
+      [``Tree.leaf, ``Tree.node, ``Tree.branch,
+        ``TreeList.nil, ``TreeList.cons] := rfl
+
+theorem treeRecursors_names :
+    TreeGen.recursors.map (·.name) =
+      [.str ``Tree "rec", .str ``TreeList "rec"] := rfl
+
+/-- A D2 constant that is none of the nine block heads was already a D1
+constant. -/
+theorem d2Env_constants_old {c : Name} {ci : VConstant}
+    (h1 : c ≠ ``Tree) (h2 : c ≠ ``TreeList)
+    (h3 : c ≠ ``Tree.leaf) (h4 : c ≠ ``Tree.node) (h5 : c ≠ ``Tree.branch)
+    (h6 : c ≠ ``TreeList.nil) (h7 : c ≠ ``TreeList.cons)
+    (h8 : c ≠ .str ``Tree "rec") (h9 : c ≠ .str ``TreeList "rec")
+    (hci : d2Env.constants c = some ci) : d1Env.constants c = some ci := by
+  obtain ⟨trace⟩ := d2Trace
+  rw [← trace.addRules, foldl_addDefEq_constants] at hci
+  rw [foldlM_addConst_constants_old _ _ _ trace.addRecs (by
+      intro x hx
+      have : x.name ∈ TreeGen.recursors.map (·.name) := List.mem_map_of_mem hx
+      rw [treeRecursors_names] at this
+      simp only [List.mem_cons, List.not_mem_nil, or_false] at this
+      rcases this with h | h <;> rw [h]
+      · exact fun hc => h8 hc.symm
+      · exact fun hc => h9 hc.symm),
+    foldlM_addConst_constants_old _ _ _ trace.addCtors (by
+      intro x hx
+      have : x.name ∈ treeDecl.blockConstructorConstants.map (·.name) :=
+        List.mem_map_of_mem hx
+      rw [treeCtorConstants_names] at this
+      simp only [List.mem_cons, List.not_mem_nil, or_false] at this
+      rcases this with h | h | h | h | h <;> rw [h]
+      · exact fun hc => h3 hc.symm
+      · exact fun hc => h4 hc.symm
+      · exact fun hc => h5 hc.symm
+      · exact fun hc => h6 hc.symm
+      · exact fun hc => h7 hc.symm),
+    foldlM_addConst_constants_old _ _ _ trace.addTypes (by
+      intro x hx
+      have : x.name ∈ treeDecl.blockTypeConstants.map (·.name) :=
+        List.mem_map_of_mem hx
+      rw [treeTypeConstants_names] at this
+      simp only [List.mem_cons, List.not_mem_nil, or_false] at this
+      rcases this with h | h <;> rw [h]
+      · exact fun hc => h1 hc.symm
+      · exact fun hc => h2 hc.symm)] at hci
+  exact hci
+
+/-! ### Constant patterns of the D2 registry are inherited -/
+
+/-- Every constant pattern of the D2 inventory is a D1 pattern: the block
+contributes only iota patterns, and the extension patterns are literally the
+D1 definition patterns.  Stated with an explicit pattern equation so the
+dependent index of `AssembledPat` can be eliminated. -/
+theorem d2Pat_at_const_aux {p : Pattern} {r : p.RHS × p.Check}
+    (H : D2Pat p r) :
+    ∀ {c : Name} (hp : p = .const c), D1Pat (.const c) (hp ▸ r) := by
+  intro c hp
+  cases H with
+  | nat H =>
+    exfalso
+    rcases natPat_pattern H with h | h <;> rw [hp] at h <;> cases h
+  | assembled H =>
+    cases H with
+    | rule h =>
+      exfalso
+      obtain ⟨i, cc, hentry, hpat, -⟩ :=
+        VInductDecl.BlockGenerationChecked.IotaPat.recover TreeGen h
+      rw [hp] at hpat
+      cases hpat
+    | ext ext hmem =>
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl
+      · cases hp
+        exact .old .defn
+      · cases hp
+        exact .defnA
+      · cases hp
+        exact .defnB
+
+theorem d2Pat_at_const {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : D2Pat (.const c) r) : D1Pat (.const c) r :=
+  d2Pat_at_const_aux H rfl
+
+/-! ### Constructor-classification transport at old constants -/
+
+/-- A constructor-shaped D2 classification at a D1 constant restricts to the
+same constructor classification in D1. -/
+theorem d2CtorToD1 (univs : Nat) {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci)
+    (H : @CtorBundle.IsCtor (d2Params univs) c) :
+    @CtorBundle.IsCtor (d1Params univs) c := by
+  change ∃ cl, d2Classify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true at H
+  change ∃ cl, d1Classify c = some cl ∧
+    (match cl with | .ctor _ | .etaCtor _ _ => true | _ => false) = true
+  rwa [d2Classify_of_d1Const hreg] at H
+
+theorem d2CtorToD1_cl_eq (univs : Nat) {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c) :
+    (@CtorBundle.IsCtor.cl (d1Params univs) c
+        (d2CtorToD1 univs hreg cl)).1 =
+      (@CtorBundle.IsCtor.cl (d2Params univs) c cl).1 := by
+  let oldCl := @CtorBundle.IsCtor.cl (d1Params univs) c
+    (d2CtorToD1 univs hreg cl)
+  let newCl := @CtorBundle.IsCtor.cl (d2Params univs) c cl
+  have hnewD1 : d1Classify c = some newCl.1 := by
+    have hnew := newCl.2.1
+    change d2Classify c = some newCl.1 at hnew
+    rwa [d2Classify_of_d1Const hreg] at hnew
+  have hold : d1Classify c = some oldCl.1 := oldCl.2.1
+  exact Option.some.inj (hold.symm.trans hnewD1)
+
+/-- Reindex a D1 constructor bundle through the generic syntax transport and
+the classifier restriction. -/
+noncomputable def d1CtorBundleToD2 (univs : Nat) {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c)
+    (F : @CtorBundle (d1Params univs) c (d2CtorToD1 univs hreg cl)) :
+    @CtorBundle (d2Params univs) c cl := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  refine @CtorBundle.mk (d2Params univs) c cl I
+    (Ts.map (transportExpr (d1d2 univs)))
+    (args.map (transportExpr (d1d2 univs)))
+    (transportLevel (d1d2 univs) u) ?_ ?_ ?_
+  · rw [List.length_map, hlen, d2CtorToD1_cl_eq univs hreg cl]
+  · change d1Classify I = some (.indTy args.length) at hclI
+    letI : Params := d2Params univs
+    change d2Classify I =
+      some (.indTy (args.map (transportExpr (d1d2 univs))).length)
+    simpa using d1Classify_agrees hclI
+  · intro hzero
+    have hback := congrArg (transportLevel (d1d2 univs).symm) hzero
+    apply hu0
+    apply Subtype.ext
+    exact congrArg Subtype.val hback
+
+@[simp] theorem d1CtorBundleToD2_rhs (univs : Nat) {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c)
+    (F : @CtorBundle (d1Params univs) c (d2CtorToD1 univs hreg cl))
+    (ls : List (@SLevel (d1Params univs))) :
+    transportExpr (d1d2 univs)
+        (@CtorBundle.rhs (d1Params univs) c (d2CtorToD1 univs hreg cl) F ls) =
+      @CtorBundle.rhs (d2Params univs) c cl
+        (d1CtorBundleToD2 univs hreg cl F)
+        (ls.map (transportLevel (d1d2 univs))) := by
+  rcases F with ⟨I, Ts, args, u, hlen, hclI, hu0⟩
+  simp [CtorBundle.rhs, d1CtorBundleToD2,
+    transportExpr_foldr_forallE, transportExpr_foldr_app]
+
+@[simp] theorem d1CtorBundleToD2_u (univs : Nat) {c : Name} {ci : VConstant}
+    (hreg : d1Env.constants c = some ci)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c)
+    (F : @CtorBundle (d1Params univs) c (d2CtorToD1 univs hreg cl)) :
+    @CtorBundle.u (d2Params univs) c cl (d1CtorBundleToD2 univs hreg cl F) =
+      transportLevel (d1d2 univs)
+        (@CtorBundle.u (d1Params univs) c (d2CtorToD1 univs hreg cl) F) := by
+  cases F
+  rfl
+
+/-! ### Judgment transport -/
+
+theorem d1IsDefEq_to_d2 (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {e₁ e₂ A : @SExpr (d1Params univs)}
+    (H : @IsDefEq (d1Params univs) Gamma e₁ e₂ A) :
+    @IsDefEq (d2Params univs) (Gamma.map (transportExpr (d1d2 univs)))
+      (transportExpr (d1d2 univs) e₁) (transportExpr (d1d2 univs) e₂)
+      (transportExpr (d1d2 univs) A) := by
+  letI : Params := d2Params univs
+  induction H with
+  | bvar h => exact .bvar (transportLookup (d1d2 univs) h)
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [transportExpr_sort, transportLevel_succ] using
+      (IsDefEq.sort : IsDefEq (Gamma.map (transportExpr (d1d2 univs)))
+        (.sort (transportLevel (d1d2 univs) l))
+        (.sort (transportLevel (d1d2 univs) l))
+        (.sort (.succ (transportLevel (d1d2 univs) l))))
+  | @const c ci Gamma ls hreg hlen =>
+    simpa only [transportExpr_const, transportExpr_mkInst] using
+      (IsDefEq.const (Γ := Gamma.map (transportExpr (d1d2 univs)))
+        (ls := ls.map (transportLevel (d1d2 univs)))
+        (d1Env_le_d2Env.constants hreg) (by simpa using hlen))
+  | appDF _ _ ihf iha =>
+    rw [transportExpr_app, transportExpr_app, transportExpr_inst]
+    exact IsDefEq.appDF ihf iha
+  | lamDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, transportExpr_lam, transportExpr_forallE] using
+      IsDefEq.lamDF ihA ihBody
+  | forallEDF _ _ ihA ihBody =>
+    simpa only [List.map_cons, transportExpr_forallE, transportExpr_sort,
+      transportLevel_imax] using IsDefEq.forallEDF ihA ihBody
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ ihBody ihArg =>
+    simpa only [List.map_cons, transportExpr_app, transportExpr_lam,
+      transportExpr_inst] using IsDefEq.beta ihBody ihArg
+  | eta _ ih =>
+    rw [transportExpr_lam, transportExpr_app, transportExpr_bvar,
+      transportExpr_forallE, transportExpr_lift']
+    exact IsDefEq.eta ih
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @extra df Gamma ls hreg hlen =>
+    simpa only [transportExpr_mkInst] using
+      (IsDefEq.extra (Γ := Gamma.map (transportExpr (d1d2 univs)))
+        (ls := ls.map (transportLevel (d1d2 univs)))
+        (d1Env_le_d2Env.defeqs hreg) (by simpa using hlen))
+
+noncomputable def d1Action_to_d2 (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))} {p : Pattern}
+    {r : p.RHS × p.Check} {e A : @SExpr (d1Params univs)}
+    {m₁ : List (@SLevel (d1Params univs))}
+    {m₂ : p.Path → @SExpr (d1Params univs)}
+    (H : @Pattern.Action (d1Params univs) Gamma p r e m₁ m₂ A) :
+    @Pattern.Action (d2Params univs)
+      (Gamma.map (transportExpr (d1d2 univs))) p r
+      (transportExpr (d1d2 univs) e) (m₁.map (transportLevel (d1d2 univs)))
+      (fun path => transportExpr (d1d2 univs) (m₂ path))
+      (transportExpr (d1d2 univs) A) := by
+  rcases H with ⟨hpat, hmatched, dfs, hdefeqs, hchecked, hsound⟩
+  change D1Pat p r at hpat
+  refine @Pattern.Action.mk (d2Params univs)
+    (Gamma := Gamma.map (transportExpr (d1d2 univs))) (p := p) (r := r)
+    (e := transportExpr (d1d2 univs) e)
+    (m1 := m₁.map (transportLevel (d1d2 univs)))
+    (m2 := fun path => transportExpr (d1d2 univs) (m₂ path))
+    (A := transportExpr (d1d2 univs) A) (d1Pat_to_d2 hpat)
+    (transportMatchesS (d1d2 univs) hmatched)
+    (transportDfs (d1d2 univs) dfs) ?_ ?_ ?_
+  · rw [transportDfs_map_snd, hdefeqs]
+    exact transport_defeqsS (d1d2 univs) r.2 m₁ m₂
+  · intro a b B hmem
+    simp only [transportDfs, List.mem_map] at hmem
+    obtain ⟨⟨B₀, a₀, b₀⟩, hmem₀, heq⟩ := hmem
+    cases heq
+    exact d1IsDefEq_to_d2 univs (hchecked a₀ b₀ B₀ hmem₀)
+  · simpa only [transportExpr_rhs_applyS] using d1IsDefEq_to_d2 univs hsound
+
+/-- Transport a D1 evidence-rich derivation into the block-extended D2
+syntax and registry.  The `const` and `defn` cases carry the inherited
+definition patterns across the `d1Pat_to_d2` inclusion, and reindex
+constructor bundles through the D2 classifier restriction at old
+constants. -/
+noncomputable def d1StrongToD2 (univs : Nat)
+    {Gamma : List (@SExpr (d1Params univs))}
+    {e₁ e₂ A : @SExpr (d1Params univs)}
+    (H : @IsDefEqStrong (d1Params univs) Gamma e₁ e₂ A) :
+    @IsDefEqStrong (d2Params univs) (Gamma.map (transportExpr (d1d2 univs)))
+      (transportExpr (d1d2 univs) e₁) (transportExpr (d1d2 univs) e₂)
+      (transportExpr (d1d2 univs) A) := by
+  letI : Params := d2Params univs
+  induction H with
+  | bvar h _ ihA => exact .bvar (transportLookup (d1d2 univs) h) ihA
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+  | @sort Gamma l =>
+    simpa only [transportExpr_sort, transportLevel_succ] using
+      (IsDefEqStrong.sort : IsDefEqStrong
+        (Gamma.map (transportExpr (d1d2 univs)))
+        (.sort (transportLevel (d1d2 univs) l))
+        (.sort (transportLevel (d1d2 univs) l))
+        (.sort (.succ (transportLevel (d1d2 univs) l))))
+  | @const c ci Gamma ls u hreg hlen hTy F hF hDef ihTy ihF ihDef =>
+    let F' : ∀ cl : CtorBundle.IsCtor c, CtorBundle c cl := fun cl =>
+      d1CtorBundleToD2 univs hreg cl (F (d2CtorToD1 univs hreg cl))
+    simpa only [transportExpr_const, transportExpr_mkInst] using
+      (@IsDefEqStrong.const (d2Params univs) c ci
+      (Gamma.map (transportExpr (d1d2 univs)))
+      (ls.map (transportLevel (d1d2 univs))) (transportLevel (d1d2 univs) u)
+      (d1Env_le_d2Env.constants hreg)
+      (by simpa only [List.length_map] using hlen) (by
+        simpa only [transportExpr_mkInst, transportExpr_sort] using ihTy)
+      F' (by
+        intro cl
+        dsimp only [F']
+        rw [← d1CtorBundleToD2_rhs univs hreg cl
+            (F (d2CtorToD1 univs hreg cl)) ls,
+          d1CtorBundleToD2_u univs hreg cl (F (d2CtorToD1 univs hreg cl))]
+        have H := ihF (d2CtorToD1 univs hreg cl)
+        simp only [transportExpr_mkInst, transportExpr_sort] at H
+        exact H) (by
+        intro r hpat
+        have hold : D1Pat (.const c) r := d2Pat_at_const hpat
+        have H := ihDef hold
+        rw [transportExpr_rhs_applyS] at H
+        have hm2 : (fun path => transportExpr (d1d2 univs) (Empty.elim path)) =
+            (Empty.elim :
+              (Pattern.const c).Path → @SExpr (d2Params univs)) :=
+          funext fun path => nomatch path
+        rw [hm2] at H
+        simpa only [transportExpr_const, transportExpr_mkInst] using H))
+  | appDF _ _ _ _ _ ihA ihCod ihf iha ihResult =>
+    rw [transportExpr_inst, transportExpr_inst, transportExpr_sort] at ihResult
+    simpa only [List.map_cons, transportExpr_app, transportExpr_forallE,
+      transportExpr_inst] using
+      IsDefEqStrong.appDF ihA ihCod ihf iha ihResult
+  | lamDF _ _ _ _ _ ihA ihB ihB' ihBody ihBody' =>
+    simpa only [List.map_cons, transportExpr_lam, transportExpr_forallE] using
+      IsDefEqStrong.lamDF ihA ihB ihB' ihBody ihBody'
+  | forallEDF _ _ _ ihA ihBody ihBody' =>
+    simpa only [List.map_cons, transportExpr_forallE, transportExpr_sort,
+      transportLevel_imax] using
+      IsDefEqStrong.forallEDF ihA ihBody ihBody'
+  | defeqDF _ _ ihA ihe => exact .defeqDF ihA ihe
+  | beta _ _ _ _ ihBody ihArg ihApp ihInst =>
+    simp only [transportExpr_app, transportExpr_lam,
+      transportExpr_inst] at ihApp
+    simp only [transportExpr_inst] at ihInst
+    simpa only [List.map_cons, transportExpr_app, transportExpr_lam,
+      transportExpr_inst] using
+      IsDefEqStrong.beta ihBody ihArg ihApp ihInst
+  | @eta Gamma e A B _ _ ihTerm ihLam =>
+    rw [transportExpr_lam, transportExpr_app, transportExpr_lift',
+      transportExpr_bvar, transportExpr_forallE] at ihLam ⊢
+    exact IsDefEqStrong.eta ihTerm ihLam
+  | proofIrrel _ _ _ ihp ihh ihh' => exact .proofIrrel ihp ihh ihh'
+  | @defn c ci Gamma ls u r hreg hlen hTy F hF action hRhs ihTy ihF ihRhs =>
+    have hm2 : (fun path => transportExpr (d1d2 univs) (Empty.elim path)) =
+        (Empty.elim :
+          (Pattern.const c).Path → @SExpr (d2Params univs)) :=
+      funext fun path => nomatch path
+    let F' : ∀ cl : CtorBundle.IsCtor c, CtorBundle c cl := fun cl =>
+      d1CtorBundleToD2 univs hreg cl (F (d2CtorToD1 univs hreg cl))
+    have action' := d1Action_to_d2 univs action
+    rw [transportExpr_const, transportExpr_mkInst, hm2] at action'
+    have hRhs' := ihRhs
+    rw [transportExpr_rhs_applyS, hm2, transportExpr_mkInst] at hRhs'
+    have hTy' := ihTy
+    rw [transportExpr_mkInst, transportExpr_sort] at hTy'
+    have hF' : ∀ cl, IsDefEqStrong (Gamma.map (transportExpr (d1d2 univs)))
+        (SExpr.mkInst (ls.map (transportLevel (d1d2 univs))) ci.type)
+        ((F' cl).rhs (ls.map (transportLevel (d1d2 univs))))
+        (.sort (F' cl).u) := by
+      intro cl
+      dsimp only [F']
+      rw [← d1CtorBundleToD2_rhs univs hreg cl
+          (F (d2CtorToD1 univs hreg cl)) ls,
+        d1CtorBundleToD2_u univs hreg cl (F (d2CtorToD1 univs hreg cl))]
+      have H := ihF (d2CtorToD1 univs hreg cl)
+      simp only [transportExpr_mkInst, transportExpr_sort] at H
+      exact H
+    simpa only [transportExpr_const, transportExpr_mkInst,
+      transportExpr_rhs_applyS, hm2] using
+      IsDefEqStrong.defn (d1Env_le_d2Env.constants hreg)
+        (by simpa only [List.length_map] using hlen)
+        hTy' F' hF' action' hRhs'
+  | extra action _ _ ihLeft ihRight =>
+    rw [transportExpr_rhs_applyS] at ihRight
+    simpa only [transportExpr_rhs_applyS] using
+      IsDefEqStrong.extra (d1Action_to_d2 univs action) ihLeft ihRight
+
+/-! ## D2 semantic machinery
+
+The type-uniqueness, spine-view, and path-spine tools the semantic layer
+needs are *not* re-proved here: they are the generic engine of
+`Lean4Lean/Experimental/SExprGenericReplay.lean` (R2), instantiated at the
+block-extended instance through one `SExpr.Replay` certificate.  This is the
+first consumer of that module; D0/D1's hand-rolled copies are a recorded
+deletion follow-up. -/
+
+/-- The ambient replay certificate of the D2 instance: the block-extended
+environment is well formed, and its (empty) structure-eta registry is
+sound. -/
+theorem d2Replay (univs : Nat) : @SExpr.Replay (d2Params univs) :=
+  @SExpr.Replay.mk (d2Params univs) d2Env_wf (d2StructureEtaSound univs)
+
+
+
+abbrev D2ContextValid (univs : Nat)
+    (Gamma : List (@SExpr (d2Params univs))) : Prop :=
+  @SExpr.CtxValid (d2Params univs) Gamma
+
+abbrev D2TypesDefEq (univs : Nat) {Gamma : List (@SExpr (d2Params univs))}
+    (A B : @SExpr (d2Params univs)) : Prop :=
+  @SExpr.TypesDefEq (d2Params univs) Gamma A B
+
+theorem d2TypeUniq (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {x A B : @SExpr (d2Params univs)}
+    (hGamma : D2ContextValid univs Gamma)
+    (hxA : @IsDefEq (d2Params univs) Gamma x x A)
+    (hxB : @IsDefEq (d2Params univs) Gamma x x B) :
+    D2TypesDefEq (Gamma := Gamma) univs A B :=
+  @SExpr.typeUniq (d2Params univs) (d2Replay univs) _ _ _ _ hGamma hxA hxB
+
+theorem d2TypesTrans (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {A B C : @SExpr (d2Params univs)}
+    (hGamma : D2ContextValid univs Gamma)
+    (hAB : D2TypesDefEq (Gamma := Gamma) univs A B)
+    (hBC : D2TypesDefEq (Gamma := Gamma) univs B C) :
+    D2TypesDefEq (Gamma := Gamma) univs A C :=
+  @SExpr.typesTrans (d2Params univs) (d2Replay univs) _ _ _ _ hGamma hAB hBC
+
+theorem d2TypesInst (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {D B B' e : @SExpr (d2Params univs)}
+    (hBB' : D2TypesDefEq (Gamma := D :: Gamma) univs B B')
+    (he : @IsDefEq (d2Params univs) Gamma e e D) :
+    D2TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.inst (d2Params univs) B e)
+      (@SExpr.inst (d2Params univs) B' e) :=
+  @SExpr.typesInst (d2Params univs) _ _ _ _ _ hBB' he
+
+theorem d2ForallEInv (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {A B A' B' : @SExpr (d2Params univs)}
+    (hGamma : D2ContextValid univs Gamma)
+    (hPi : D2TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d2Params univs) A B)
+      (@SExpr.forallE (d2Params univs) A' B')) :
+    D2TypesDefEq (Gamma := Gamma) univs A A' ∧
+      D2TypesDefEq (Gamma := A :: Gamma) univs B B' :=
+  @SExpr.forallEInv (d2Params univs) (d2Replay univs) _ _ _ _ _ hGamma hPi
+
+noncomputable def d2SpineConsView (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {D B Head e R : @SExpr (d2Params univs)}
+    {es : List (@SExpr (d2Params univs))}
+    (hGamma : D2ContextValid univs Gamma)
+    (hHead : D2TypesDefEq (Gamma := Gamma) univs
+      (@SExpr.forallE (d2Params univs) D B) Head)
+    (H : @SpineWF (d2Params univs) Gamma Head (e :: es) R) :
+    @SExpr.SpineConsView (d2Params univs) Gamma D B e es R :=
+  @SExpr.spineConsView (d2Params univs) (d2Replay univs) _ _ _ _ _ _ _ hGamma hHead H
+
+theorem d2PathSpineOfSpineWF (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {alpha : Type}
+    {value type : alpha → @SExpr (d2Params univs)}
+    {A B : @SExpr (d2Params univs)} {paths : List alpha}
+    (hGamma : D2ContextValid univs Gamma)
+    (htyped : ∀ path, @IsDefEq (d2Params univs) Gamma
+      (value path) (value path) (type path))
+    (H : @SpineWF (d2Params univs) Gamma A (paths.map value) B) :
+    @PathSpineWF (d2Params univs) Gamma alpha value type A paths B :=
+  @SExpr.pathSpineOfSpineWF (d2Params univs) (d2Replay univs) _ _ _ _ _ _ _ hGamma htyped H
+
+/-! ## The block heads: lookups, classifications, and strong typings -/
+
+theorem d2Env_tree_lookup :
+    d2Env.constants ``Tree = some treeType.toVConstant :=
+  d2Env_family_lookup (List.mem_of_getElem? (i := 0) rfl)
+
+theorem d2Env_treeList_lookup :
+    d2Env.constants ``TreeList = some treeListType.toVConstant :=
+  d2Env_family_lookup (List.mem_of_getElem? (i := 1) rfl)
+
+theorem d2Env_treeLeaf_lookup :
+    d2Env.constants ``Tree.leaf = some treeType.ctors[0].toVConstant :=
+  d2Env_ctor_lookup (List.mem_of_getElem? (i := 0) rfl)
+
+theorem d2Env_treeNode_lookup :
+    d2Env.constants ``Tree.node = some treeType.ctors[1].toVConstant :=
+  d2Env_ctor_lookup (List.mem_of_getElem? (i := 1) rfl)
+
+theorem d2Env_treeBranch_lookup :
+    d2Env.constants ``Tree.branch = some treeType.ctors[2].toVConstant :=
+  d2Env_ctor_lookup (List.mem_of_getElem? (i := 2) rfl)
+
+theorem d2Env_treeListNil_lookup :
+    d2Env.constants ``TreeList.nil = some treeListType.ctors[0].toVConstant :=
+  d2Env_ctor_lookup (List.mem_of_getElem? (i := 3) rfl)
+
+theorem d2Env_treeListCons_lookup :
+    d2Env.constants ``TreeList.cons = some treeListType.ctors[1].toVConstant :=
+  d2Env_ctor_lookup (List.mem_of_getElem? (i := 4) rfl)
+
+theorem d2Env_treeRec_lookup :
+    d2Env.constants (.str ``Tree "rec") =
+      some TreeGen.recursors[0].toVConstant :=
+  d2Env_rec_lookup (List.mem_of_getElem? (i := 0) rfl)
+
+theorem d2Env_treeListRec_lookup :
+    d2Env.constants (.str ``TreeList "rec") =
+      some TreeGen.recursors[1].toVConstant :=
+  d2Env_rec_lookup (List.mem_of_getElem? (i := 1) rfl)
+
+/-- Constructor-shaped classifications of the D2 table: the five block
+constructors, or an inherited D1 classification. -/
+theorem d2Classify_ctor_cases {c : Name} {cl : Classification}
+    (hc : d2Classify c = some cl) (hshape : ctorLike cl = true) :
+    (c = ``Tree.leaf ∧ cl = .ctor 2) ∨ (c = ``Tree.node ∧ cl = .ctor 2) ∨
+      (c = ``Tree.branch ∧ cl = .ctor 2) ∨
+      (c = ``TreeList.nil ∧ cl = .ctor 1) ∨
+      (c = ``TreeList.cons ∧ cl = .ctor 3) ∨ d1Classify c = some cl := by
+  by_cases h1 : c = ``Tree
+  · subst c
+    simp [d2Classify] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  by_cases h2 : c = ``TreeList
+  · subst c
+    simp [d2Classify, h1] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  by_cases h3 : c = ``Tree.leaf
+  · subst c
+    simp [d2Classify, h1, h2] at hc
+    exact .inl ⟨rfl, hc.symm⟩
+  by_cases h4 : c = ``Tree.node
+  · subst c
+    simp [d2Classify, h1, h2, h3] at hc
+    exact .inr (.inl ⟨rfl, hc.symm⟩)
+  by_cases h5 : c = ``Tree.branch
+  · subst c
+    simp [d2Classify, h1, h2, h3, h4] at hc
+    exact .inr (.inr (.inl ⟨rfl, hc.symm⟩))
+  by_cases h6 : c = ``TreeList.nil
+  · subst c
+    simp [d2Classify, h1, h2, h3, h4, h5] at hc
+    exact .inr (.inr (.inr (.inl ⟨rfl, hc.symm⟩)))
+  by_cases h7 : c = ``TreeList.cons
+  · subst c
+    simp [d2Classify, h1, h2, h3, h4, h5, h6] at hc
+    exact .inr (.inr (.inr (.inr (.inl ⟨rfl, hc.symm⟩))))
+  by_cases h8 : c = .str ``Tree "rec"
+  · subst c
+    simp [d2Classify, h1, h2, h3, h4, h5, h6, h7] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  by_cases h9 : c = .str ``TreeList "rec"
+  · subst c
+    simp [d2Classify, h1, h2, h3, h4, h5, h6, h7, h8] at hc
+    subst cl
+    simp [ctorLike] at hshape
+  refine .inr (.inr (.inr (.inr (.inr ?_))))
+  simpa [d2Classify, h1, h2, h3, h4, h5, h6, h7, h8, h9] using hc
+
+theorem treeType_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``Tree) : False := by
+  letI : Params := d2Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hc := cl.cl.2.1
+  change d2Classify ``Tree = some cl.cl.1 at hc
+  simp [d2Classify] at hc
+  rw [← hc] at hshape
+  simp [ctorLike] at hshape
+
+theorem treeListType_not_ctor (univs : Nat)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``TreeList) : False := by
+  letI : Params := d2Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hc := cl.cl.2.1
+  change d2Classify ``TreeList = some cl.cl.1 at hc
+  simp [d2Classify] at hc
+  rw [← hc] at hshape
+  simp [ctorLike] at hshape
+
+/-- No D2 constant pattern lives at a name fresh over `d1Env`: the three
+definition patterns name D1 constants. -/
+theorem d2Pat_no_const_fresh {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (hfresh : d1Env.constants c = none) (H : D2Pat (.const c) r) : False := by
+  have H1 := d2Pat_at_const H
+  cases H1 with
+  | old H0 =>
+    cases H0 with
+    | iota H' => rcases natPat_pattern H' with h | h <;> cases h
+    | defn =>
+      rw [d0Env_le_d1Env.constants d0Env_d0Def_lookup] at hfresh
+      cases hfresh
+  | defnA =>
+    rw [d1Env_d1MutA_lookup] at hfresh
+    cases hfresh
+  | defnB =>
+    rw [d1Env_d1MutB_lookup] at hfresh
+    cases hfresh
+
+/-! ### Strong typings of the family heads and constructor types -/
+
+theorem d2TreeStrong (univs : Nat) (Gamma : List (@SExpr (d2Params univs)))
+    (l : @SLevel (d2Params univs)) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.const (d2Params univs) ``Tree [l])
+      (@SExpr.const (d2Params univs) ``Tree [l])
+      (@SExpr.forallE (d2Params univs)
+        (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))
+        (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))) := by
+  letI : Params := d2Params univs
+  let F : ∀ cl : CtorBundle.IsCtor ``Tree, CtorBundle ``Tree cl := fun cl =>
+    (treeType_not_ctor univs cl).elim
+  have H : IsDefEqStrong Gamma (.const ``Tree [l]) (.const ``Tree [l])
+      (SExpr.mkInst [l] treeType.toVConstant.type) := by
+    refine .const (u := SLevel.imax l.succ.succ l.succ.succ)
+      d2Env_tree_lookup rfl ?_ F ?_ ?_
+    · change IsDefEqStrong Gamma
+        (.forallE (.sort l.succ) (.sort l.succ))
+        (.forallE (.sort l.succ) (.sort l.succ))
+        (.sort (SLevel.imax l.succ.succ l.succ.succ))
+      exact .forallEDF .sort .sort .sort
+    · intro cl
+      exact (treeType_not_ctor univs cl).elim
+    · intro r hpat
+      exact (d2Pat_no_const_fresh tree_fresh hpat).elim
+  exact H
+
+theorem d2TreeListStrong (univs : Nat)
+    (Gamma : List (@SExpr (d2Params univs)))
+    (l : @SLevel (d2Params univs)) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.const (d2Params univs) ``TreeList [l])
+      (@SExpr.const (d2Params univs) ``TreeList [l])
+      (@SExpr.forallE (d2Params univs)
+        (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))
+        (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))) := by
+  letI : Params := d2Params univs
+  let F : ∀ cl : CtorBundle.IsCtor ``TreeList, CtorBundle ``TreeList cl :=
+    fun cl => (treeListType_not_ctor univs cl).elim
+  have H : IsDefEqStrong Gamma
+      (.const ``TreeList [l]) (.const ``TreeList [l])
+      (SExpr.mkInst [l] treeListType.toVConstant.type) := by
+    refine .const (u := SLevel.imax l.succ.succ l.succ.succ)
+      d2Env_treeList_lookup rfl ?_ F ?_ ?_
+    · change IsDefEqStrong Gamma
+        (.forallE (.sort l.succ) (.sort l.succ))
+        (.forallE (.sort l.succ) (.sort l.succ))
+        (.sort (SLevel.imax l.succ.succ l.succ.succ))
+      exact .forallEDF .sort .sort .sort
+    · intro cl
+      exact (treeListType_not_ctor univs cl).elim
+    · intro r hpat
+      exact (d2Pat_no_const_fresh treeList_fresh hpat).elim
+  exact H
+
+/-- Application of the `Tree` head to a type argument. -/
+theorem d2TreeAppStrong (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))} {x : @SExpr (d2Params univs)}
+    (l : @SLevel (d2Params univs))
+    (hx : @IsDefEqStrong (d2Params univs) Gamma x x
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.app (d2Params univs)
+        (@SExpr.const (d2Params univs) ``Tree [l]) x)
+      (@SExpr.app (d2Params univs)
+        (@SExpr.const (d2Params univs) ``Tree [l]) x)
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l)) := by
+  letI : Params := d2Params univs
+  have h := IsDefEqStrong.appDF (.sort : IsDefEqStrong Gamma
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+    (.sort : IsDefEqStrong (.sort l.succ :: Gamma)
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+    (d2TreeStrong univs Gamma l) hx
+    (.sort : IsDefEqStrong Gamma
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+  exact h
+
+theorem d2TreeListAppStrong (univs : Nat)
+    {Gamma : List (@SExpr (d2Params univs))} {x : @SExpr (d2Params univs)}
+    (l : @SLevel (d2Params univs))
+    (hx : @IsDefEqStrong (d2Params univs) Gamma x x
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l))) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.app (d2Params univs)
+        (@SExpr.const (d2Params univs) ``TreeList [l]) x)
+      (@SExpr.app (d2Params univs)
+        (@SExpr.const (d2Params univs) ``TreeList [l]) x)
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l)) := by
+  letI : Params := d2Params univs
+  have h := IsDefEqStrong.appDF (.sort : IsDefEqStrong Gamma
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+    (.sort : IsDefEqStrong (.sort l.succ :: Gamma)
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+    (d2TreeListStrong univs Gamma l) hx
+    (.sort : IsDefEqStrong Gamma
+      (.sort l.succ) (.sort l.succ) (.sort l.succ.succ))
+  exact h
+
+/-! ## `Params.Semantic.ctor` for the block-extended inventory
+
+The five block constructors are Type-sorted, so their bundles are
+unproblematic: each constructor's instantiated type is *literally* the
+bundle's `rhs` (the field telescope over the family head applied to the
+parameter), so the bundle obligation reduces to a self-typing of that Pi
+tower.  Old constants transport through `d1Ctor`. -/
+
+/-- The bundle level of a two-field Type-sorted constructor is nonzero. -/
+theorem d2CtorLevel_ne_zero (univs : Nat)
+    (u : @SLevel (d2Params univs)) (hu : ∀ v, 0 < u.1 v) :
+    u ≠ @SLevel.zero (d2Params univs) := by
+  intro h
+  have hv := congrArg (fun l : @SLevel (d2Params univs) => l.1 []) h
+  have hpos := hu []
+  have hz : (@SLevel.zero (d2Params univs)).1 [] = 0 := rfl
+  have hv' : u.1 [] = (@SLevel.zero (d2Params univs)).1 [] := hv
+  rw [hv', hz] at hpos
+  exact absurd hpos (Nat.lt_irrefl 0)
+
+theorem d2Imax_pos (univs : Nat) (u v : @SLevel (d2Params univs))
+    (hv : ∀ w, 0 < v.1 w) : ∀ w, 0 < (@SLevel.imax (d2Params univs) u v).1 w := by
+  intro w
+  have hw := hv w
+  show 0 < Lean.Nat.imax (u.1 w) (v.1 w)
+  simp only [Lean.Nat.imax]
+  rw [if_neg (by omega)]
+  exact Nat.lt_of_lt_of_le hw (Nat.le_max_right _ _)
+
+theorem d2Succ_pos (univs : Nat) (u : @SLevel (d2Params univs)) :
+    ∀ w, 0 < (@SLevel.succ (d2Params univs) u).1 w := fun _ => Nat.succ_pos _
+
+/-- Self-typing of the `α` binder variable at the head of every block
+constructor's telescope. -/
+theorem d2AlphaStrong (univs : Nat) (Gamma : List (@SExpr (d2Params univs)))
+    (l : @SLevel (d2Params univs)) :
+    @IsDefEqStrong (d2Params univs)
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l) :: Gamma)
+      (@SExpr.bvar (d2Params univs) 0) (@SExpr.bvar (d2Params univs) 0)
+      (@SExpr.sort (d2Params univs) (@SLevel.succ (d2Params univs) l)) := by
+  letI : Params := d2Params univs
+  exact .bvar .zero (by exact IsDefEqStrong.sort)
+
+theorem d2BvarStrong (univs : Nat) {Gamma : List (@SExpr (d2Params univs))}
+    {i : Nat} {A : @SExpr (d2Params univs)}
+    {u : @SLevel (d2Params univs)}
+    (h : @Lookup (d2Params univs) Gamma i A)
+    (hA : @IsDefEqStrong (d2Params univs) Gamma A A
+      (@SExpr.sort (d2Params univs) u)) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.bvar (d2Params univs) i) (@SExpr.bvar (d2Params univs) i) A :=
+  @IsDefEqStrong.bvar (d2Params univs) Gamma i A u h hA
+
+/-- The result type of the D2 constructor bridge. -/
+def D2CtorResult (univs : Nat) {c : Name} {ci : VConstant}
+    (ls : List (@SLevel (d2Params univs)))
+    (Gamma : List (@SExpr (d2Params univs)))
+    (cl : @CtorBundle.IsCtor (d2Params univs) c) : Type :=
+  letI : Params := d2Params univs
+  {F : CtorBundle c cl //
+    IsDefEqStrong Gamma (SExpr.mkInst ls ci.type) (F.rhs ls) (.sort F.u)}
+
+section BlockBundles
+
+variable (univs : Nat)
+
+/-- `Tree.leaf`: one type parameter and one `α` field. -/
+theorem d2TreeLeafBundle {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hlen : ls.length = 1)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``Tree.leaf) :
+    Nonempty (D2CtorResult (ci := treeType.ctors[0].toVConstant)
+      univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  obtain ⟨l, rfl⟩ := List.length_eq_one_iff.mp hlen
+  have hcl : cl.cl.1 = .ctor 2 := by
+    have hc := cl.cl.2.1
+    change d2Classify ``Tree.leaf = some cl.cl.1 at hc
+    simpa [d2Classify] using hc.symm
+  let u : SLevel := .imax l.succ.succ (.imax l.succ l.succ)
+  let F : CtorBundle ``Tree.leaf cl := {
+    I := ``Tree
+    Ts := [.sort l.succ, .bvar 0]
+    args := [.bvar 1]
+    u := u
+    hlen := by simp [hcl, Classification.arity]
+    hclI := by
+      change d2Classify ``Tree = some (.indTy 1)
+      simp [d2Classify]
+    hu0 := d2CtorLevel_ne_zero univs u
+      (d2Imax_pos univs _ _ (d2Imax_pos univs _ _ (d2Succ_pos univs _))) }
+  refine ⟨⟨F, ?_⟩⟩
+  change IsDefEqStrong Gamma
+    (.forallE (.sort l.succ)
+      (.forallE (.bvar 0) ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.forallE (.sort l.succ)
+      (.forallE (.bvar 0) ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.sort u)
+  refine .forallEDF (.sort) ?_ ?_ <;>
+    exact .forallEDF (d2AlphaStrong univs Gamma l)
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+
+/-- `Tree.node`: one type parameter and one `TreeList α` field. -/
+theorem d2TreeNodeBundle {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hlen : ls.length = 1)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``Tree.node) :
+    Nonempty (D2CtorResult (ci := treeType.ctors[1].toVConstant)
+      univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  obtain ⟨l, rfl⟩ := List.length_eq_one_iff.mp hlen
+  have hcl : cl.cl.1 = .ctor 2 := by
+    have hc := cl.cl.2.1
+    change d2Classify ``Tree.node = some cl.cl.1 at hc
+    simpa [d2Classify] using hc.symm
+  let u : SLevel := .imax l.succ.succ (.imax l.succ l.succ)
+  let F : CtorBundle ``Tree.node cl := {
+    I := ``Tree
+    Ts := [.sort l.succ, (SExpr.const ``TreeList [l]).app (.bvar 0)]
+    args := [.bvar 1]
+    u := u
+    hlen := by simp [hcl, Classification.arity]
+    hclI := by
+      change d2Classify ``Tree = some (.indTy 1)
+      simp [d2Classify]
+    hu0 := d2CtorLevel_ne_zero univs u
+      (d2Imax_pos univs _ _ (d2Imax_pos univs _ _ (d2Succ_pos univs _))) }
+  refine ⟨⟨F, ?_⟩⟩
+  change IsDefEqStrong Gamma
+    (.forallE (.sort l.succ)
+      (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 0))
+        ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.forallE (.sort l.succ)
+      (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 0))
+        ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.sort u)
+  refine .forallEDF (.sort) ?_ ?_ <;>
+    exact .forallEDF
+      (d2TreeListAppStrong univs l (d2AlphaStrong univs Gamma l))
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+
+/-- `Tree.branch`: one type parameter and one higher-order
+`α → TreeList α` field. -/
+theorem d2TreeBranchBundle {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hlen : ls.length = 1)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``Tree.branch) :
+    Nonempty (D2CtorResult (ci := treeType.ctors[2].toVConstant)
+      univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  obtain ⟨l, rfl⟩ := List.length_eq_one_iff.mp hlen
+  have hcl : cl.cl.1 = .ctor 2 := by
+    have hc := cl.cl.2.1
+    change d2Classify ``Tree.branch = some cl.cl.1 at hc
+    simpa [d2Classify] using hc.symm
+  let u : SLevel := .imax l.succ.succ (.imax (.imax l.succ l.succ) l.succ)
+  let F : CtorBundle ``Tree.branch cl := {
+    I := ``Tree
+    Ts := [.sort l.succ,
+      .forallE (.bvar 0) ((SExpr.const ``TreeList [l]).app (.bvar 1))]
+    args := [.bvar 1]
+    u := u
+    hlen := by simp [hcl, Classification.arity]
+    hclI := by
+      change d2Classify ``Tree = some (.indTy 1)
+      simp [d2Classify]
+    hu0 := d2CtorLevel_ne_zero univs u
+      (d2Imax_pos univs _ _ (d2Imax_pos univs _ _ (d2Succ_pos univs _))) }
+  refine ⟨⟨F, ?_⟩⟩
+  change IsDefEqStrong Gamma
+    (.forallE (.sort l.succ)
+      (.forallE (.forallE (.bvar 0) ((SExpr.const ``TreeList [l]).app (.bvar 1)))
+        ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.forallE (.sort l.succ)
+      (.forallE (.forallE (.bvar 0) ((SExpr.const ``TreeList [l]).app (.bvar 1)))
+        ((SExpr.const ``Tree [l]).app (.bvar 1))))
+    (.sort u)
+  have hfield : ∀ Delta : List SExpr,
+      IsDefEqStrong (SExpr.sort l.succ :: Delta)
+        (.forallE (.bvar 0) ((SExpr.const ``TreeList [l]).app (.bvar 1)))
+        (.forallE (.bvar 0) ((SExpr.const ``TreeList [l]).app (.bvar 1)))
+        (.sort (.imax l.succ l.succ)) := by
+    intro Delta
+    exact .forallEDF (d2AlphaStrong univs Delta l)
+      (d2TreeListAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+      (d2TreeListAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+  refine .forallEDF (.sort) ?_ ?_ <;>
+    exact .forallEDF (hfield Gamma)
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+      (d2TreeAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+
+/-- `TreeList.nil`: one type parameter and no fields. -/
+theorem d2TreeListNilBundle {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hlen : ls.length = 1)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``TreeList.nil) :
+    Nonempty (D2CtorResult (ci := treeListType.ctors[0].toVConstant)
+      univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  obtain ⟨l, rfl⟩ := List.length_eq_one_iff.mp hlen
+  have hcl : cl.cl.1 = .ctor 1 := by
+    have hc := cl.cl.2.1
+    change d2Classify ``TreeList.nil = some cl.cl.1 at hc
+    simpa [d2Classify] using hc.symm
+  let u : SLevel := .imax l.succ.succ l.succ
+  let F : CtorBundle ``TreeList.nil cl := {
+    I := ``TreeList
+    Ts := [.sort l.succ]
+    args := [.bvar 0]
+    u := u
+    hlen := by simp [hcl, Classification.arity]
+    hclI := by
+      change d2Classify ``TreeList = some (.indTy 1)
+      simp [d2Classify]
+    hu0 := d2CtorLevel_ne_zero univs u
+      (d2Imax_pos univs _ _ (d2Succ_pos univs _)) }
+  refine ⟨⟨F, ?_⟩⟩
+  change IsDefEqStrong Gamma
+    (.forallE (.sort l.succ) ((SExpr.const ``TreeList [l]).app (.bvar 0)))
+    (.forallE (.sort l.succ) ((SExpr.const ``TreeList [l]).app (.bvar 0)))
+    (.sort u)
+  exact .forallEDF (.sort)
+    (d2TreeListAppStrong univs l (d2AlphaStrong univs Gamma l))
+    (d2TreeListAppStrong univs l (d2AlphaStrong univs Gamma l))
+
+/-- `TreeList.cons`: one type parameter, a `Tree α` head and a
+`TreeList α` tail. -/
+theorem d2TreeListConsBundle {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hlen : ls.length = 1)
+    (cl : @CtorBundle.IsCtor (d2Params univs) ``TreeList.cons) :
+    Nonempty (D2CtorResult (ci := treeListType.ctors[1].toVConstant)
+      univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  obtain ⟨l, rfl⟩ := List.length_eq_one_iff.mp hlen
+  have hcl : cl.cl.1 = .ctor 3 := by
+    have hc := cl.cl.2.1
+    change d2Classify ``TreeList.cons = some cl.cl.1 at hc
+    simpa [d2Classify] using hc.symm
+  let u : SLevel := .imax l.succ.succ (.imax l.succ (.imax l.succ l.succ))
+  let F : CtorBundle ``TreeList.cons cl := {
+    I := ``TreeList
+    Ts := [.sort l.succ, (SExpr.const ``Tree [l]).app (.bvar 0),
+      (SExpr.const ``TreeList [l]).app (.bvar 1)]
+    args := [.bvar 2]
+    u := u
+    hlen := by simp [hcl, Classification.arity]
+    hclI := by
+      change d2Classify ``TreeList = some (.indTy 1)
+      simp [d2Classify]
+    hu0 := d2CtorLevel_ne_zero univs u
+      (d2Imax_pos univs _ _ (d2Imax_pos univs _ _
+        (d2Imax_pos univs _ _ (d2Succ_pos univs _)))) }
+  refine ⟨⟨F, ?_⟩⟩
+  change IsDefEqStrong Gamma
+    (.forallE (.sort l.succ)
+      (.forallE ((SExpr.const ``Tree [l]).app (.bvar 0))
+        (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 1))
+          ((SExpr.const ``TreeList [l]).app (.bvar 2)))))
+    (.forallE (.sort l.succ)
+      (.forallE ((SExpr.const ``Tree [l]).app (.bvar 0))
+        (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 1))
+          ((SExpr.const ``TreeList [l]).app (.bvar 2)))))
+    (.sort u)
+  have hinner : ∀ Delta : List SExpr,
+      IsDefEqStrong ((SExpr.const ``Tree [l]).app (.bvar 0) ::
+          SExpr.sort l.succ :: Delta)
+        (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 1))
+          ((SExpr.const ``TreeList [l]).app (.bvar 2)))
+        (.forallE ((SExpr.const ``TreeList [l]).app (.bvar 1))
+          ((SExpr.const ``TreeList [l]).app (.bvar 2)))
+        (.sort (.imax l.succ l.succ)) := by
+    intro Delta
+    exact .forallEDF
+      (d2TreeListAppStrong univs l (d2BvarStrong univs (.succ .zero)
+        (by exact IsDefEqStrong.sort)))
+      (d2TreeListAppStrong univs l (d2BvarStrong univs
+        (.succ (.succ .zero)) (by exact IsDefEqStrong.sort)))
+      (d2TreeListAppStrong univs l (d2BvarStrong univs
+        (.succ (.succ .zero)) (by exact IsDefEqStrong.sort)))
+  refine .forallEDF (.sort) ?_ ?_ <;>
+    exact .forallEDF
+      (d2TreeAppStrong univs l (d2AlphaStrong univs Gamma l))
+      (hinner Gamma) (hinner Gamma)
+
+end BlockBundles
+
+/-- `Params.Semantic.ctor` for the complete D2 inventory. -/
+theorem d2Ctor_nonempty (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hci : d2Env.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c) :
+    Nonempty (D2CtorResult (ci := ci) univs ls Gamma cl) := by
+  letI : Params := d2Params univs
+  have hshape : ctorLike cl.cl.1 = true := by
+    have hs := cl.cl.2.2
+    cases hc : cl.cl.1 <;> simp [ctorLike, hc] at hs ⊢
+  have hcases := d2Classify_ctor_cases cl.cl.2.1 hshape
+  rcases hcases with ⟨rfl, -⟩ | ⟨rfl, -⟩ | ⟨rfl, -⟩ | ⟨rfl, -⟩ | ⟨rfl, -⟩ | hold
+  · obtain rfl : ci = treeType.ctors[0].toVConstant :=
+      Option.some.inj (hci.symm.trans d2Env_treeLeaf_lookup)
+    exact d2TreeLeafBundle univs hlen cl
+  · obtain rfl : ci = treeType.ctors[1].toVConstant :=
+      Option.some.inj (hci.symm.trans d2Env_treeNode_lookup)
+    exact d2TreeNodeBundle univs hlen cl
+  · obtain rfl : ci = treeType.ctors[2].toVConstant :=
+      Option.some.inj (hci.symm.trans d2Env_treeBranch_lookup)
+    exact d2TreeBranchBundle univs hlen cl
+  · obtain rfl : ci = treeListType.ctors[0].toVConstant :=
+      Option.some.inj (hci.symm.trans d2Env_treeListNil_lookup)
+    exact d2TreeListNilBundle univs hlen cl
+  · obtain rfl : ci = treeListType.ctors[1].toVConstant :=
+      Option.some.inj (hci.symm.trans d2Env_treeListCons_lookup)
+    exact d2TreeListConsBundle univs hlen cl
+  · -- an inherited constant: restrict, apply `d1Ctor`, and transport back.
+    -- `hold` classifies `c` in D1, and the nine block heads are unclassified
+    -- there, so `c` is none of them and its D2 constant is a D1 constant.
+    have hci' : d1Env.constants c = some ci :=
+      d2Env_constants_old
+        (by rintro rfl; rw [d1Classify_tree] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeList] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeLeaf] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeNode] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeBranch] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeListNil] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeListCons] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeRec] at hold; cases hold)
+        (by rintro rfl; rw [d1Classify_treeListRec] at hold; cases hold)
+        hci
+    let oldGamma := Gamma.map (transportExpr (d1d2 univs).symm)
+    let oldLs := ls.map (transportLevel (d1d2 univs).symm)
+    have oldLen : oldLs.length = ci.uvars := by simpa [oldLs] using hlen
+    let oldCl := d2CtorToD1 univs hci' cl
+    let oldF : @CtorBundle (d1Params univs) c oldCl :=
+      (d1Ctor univs (Gamma := oldGamma) (ls := oldLs) hci' oldLen oldCl).1
+    have oldProof : @IsDefEqStrong (d1Params univs) oldGamma
+        (@SExpr.mkInst (d1Params univs) oldLs ci.type)
+        (@CtorBundle.rhs (d1Params univs) c oldCl oldF oldLs)
+        (@SExpr.sort (d1Params univs)
+          (@CtorBundle.u (d1Params univs) c oldCl oldF)) :=
+      (d1Ctor univs (Gamma := oldGamma) (ls := oldLs) hci' oldLen oldCl).2
+    refine ⟨⟨d1CtorBundleToD2 univs hci' cl oldF, ?_⟩⟩
+    have H := d1StrongToD2 univs oldProof
+    dsimp only [oldGamma, oldLs] at H
+    simp only [transport_context_roundtrip, transportExpr_mkInst,
+      transportExpr_sort] at H
+    rw [d1CtorBundleToD2_rhs univs hci' cl oldF
+      (ls.map (transportLevel (d1d2 univs).symm))] at H
+    simpa only [transport_level_list_roundtrip,
+      d1CtorBundleToD2_u] using H
+
+noncomputable def d2Ctor (univs : Nat) {c : Name} {ci : VConstant}
+    {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hci : d2Env.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (cl : @CtorBundle.IsCtor (d2Params univs) c) :
+    D2CtorResult (ci := ci) univs ls Gamma cl :=
+  Classical.choice (d2Ctor_nonempty univs hci hlen cl)
+
+/-! ## `Params.Semantic.defn` for the block-extended inventory
+
+The block contributes no constant pattern, so every `defn` obligation is an
+inherited D1 one, transported. -/
+
+theorem d2Defn (univs : Nat) {c : Name}
+    {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (H : (d2Params univs).Pat (.const c) r) :
+    ∃ (value : VExpr) (closed : value.Closed),
+      r = (.fixed value closed, .true) ∧
+      ∀ {ci : VConstant} {ls : List (@SLevel (d2Params univs))}
+        {Gamma : List (@SExpr (d2Params univs))},
+        d2Env.constants c = some ci → ls.length = ci.uvars →
+        @IsDefEqStrong (d2Params univs) Gamma
+          (@SExpr.const (d2Params univs) c ls)
+          (@SExpr.mkInst (d2Params univs) ls value)
+          (@SExpr.mkInst (d2Params univs) ls ci.type) := by
+  letI : Params := d2Params univs
+  change D2Pat (.const c) r at H
+  obtain ⟨value, closed, rfl, hunfold⟩ := d1Defn univs (d2Pat_at_const H)
+  refine ⟨value, closed, rfl, ?_⟩
+  intro ci ls Gamma hci hlen
+  have hd1 : d1Env.constants c = some ci := by
+    have H1 := d2Pat_at_const H
+    cases H1 with
+    | old H0 =>
+      cases H0 with
+      | iota H' => exact (natPat_no_const univs (by exact H')).elim
+      | defn =>
+        have hlook := d0Env_le_d1Env.constants d0Env_d0Def_lookup
+        rw [hlook]
+        rw [d1Env_le_d2Env.constants hlook] at hci
+        exact hci.symm ▸ rfl
+    | defnA =>
+      rw [d1Env_d1MutA_lookup]
+      rw [d1Env_le_d2Env.constants d1Env_d1MutA_lookup] at hci
+      exact hci.symm ▸ rfl
+    | defnB =>
+      rw [d1Env_d1MutB_lookup]
+      rw [d1Env_le_d2Env.constants d1Env_d1MutB_lookup] at hci
+      exact hci.symm ▸ rfl
+  let oldGamma := Gamma.map (transportExpr (d1d2 univs).symm)
+  let oldLs := ls.map (transportLevel (d1d2 univs).symm)
+  have oldLen : oldLs.length = ci.uvars := by simpa [oldLs] using hlen
+  have H1 := d1StrongToD2 univs
+    (hunfold (ci := ci) (ls := oldLs) (Gamma := oldGamma) hd1 oldLen)
+  dsimp only [oldGamma, oldLs] at H1
+  simpa only [transport_context_roundtrip, transportExpr_const,
+    transportExpr_mkInst, transport_level_list_roundtrip] using H1
+
+/-! ## `Params.Semantic.registered`: inherited rules
+
+A registered defeq of `d2Env` is either one of the block's five generated
+rules or an inherited D1 rule.  The inherited half transports; the block
+half is one of the two parked obligations below. -/
+
+/-- The inherited half of `Params.Semantic.registered`, transported from
+D1's own certificate through the generic syntax transport. -/
+theorem d2Registered_old (univs : Nat)
+    {df : VDefEq} {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hreg : d1Env.defeqs df) (hlen : ls.length = df.uvars) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.mkInst (d2Params univs) ls df.lhs)
+      (@SExpr.mkInst (d2Params univs) ls df.rhs)
+      (@SExpr.mkInst (d2Params univs) ls df.type) := by
+  let oldGamma := Gamma.map (transportExpr (d1d2 univs).symm)
+  let oldLs := ls.map (transportLevel (d1d2 univs).symm)
+  have oldLen : oldLs.length = df.uvars := by simpa [oldLs] using hlen
+  have oldLhs : @IsDefEqStrong (d1Params univs) oldGamma
+      (@SExpr.mkInst (d1Params univs) oldLs df.lhs)
+      (@SExpr.mkInst (d1Params univs) oldLs df.lhs)
+      (@SExpr.mkInst (d1Params univs) oldLs df.type) := by
+    letI : Params := d1Params univs
+    letI : Params.Semantic := d1Semantic univs
+    exact Params.Semantic.closedHasTypeStrong (d1Env_ordered.defEqWF hreg).1
+  have oldRhs : @IsDefEqStrong (d1Params univs) oldGamma
+      (@SExpr.mkInst (d1Params univs) oldLs df.rhs)
+      (@SExpr.mkInst (d1Params univs) oldLs df.rhs)
+      (@SExpr.mkInst (d1Params univs) oldLs df.type) := by
+    letI : Params := d1Params univs
+    letI : Params.Semantic := d1Semantic univs
+    exact Params.Semantic.closedHasTypeStrong (d1Env_ordered.defEqWF hreg).2
+  have oldEq := d1Registered univs hreg oldLen oldLhs oldRhs
+  have H := d1StrongToD2 univs oldEq
+  dsimp only [oldGamma, oldLs] at H
+  simpa only [transport_context_roundtrip, transportExpr_mkInst,
+    transport_level_list_roundtrip] using H
+
+/-! ## Concrete δ-rank certificate
+
+The inductive block adds iota rules but no new constant-headed definition
+rules.  Consequently D2 inherits D1's dependency order unchanged:
+`d1mutA > d1mutB > d0def`; every block head remains at rank zero. -/
+
+def d2DeltaRankFn : Name → Nat := fun n =>
+  if n = ``ParamsD1.d1mutA then 3
+  else if n = ``ParamsD1.d1mutB then 2
+  else if n = ``ParamsD0.d0def then 1
+  else 0
+
+theorem d2NatTypeLookup :
+    d2Env.constants ``Nat = some InductiveFixtures.natType.toVConstant :=
+  d1Env_le_d2Env.constants d1NatTypeLookup
+
+theorem d2D0DefLookup :
+    d2Env.constants ``ParamsD0.d0def = some d0DefVal.toVConstant :=
+  d1Env_le_d2Env.constants d1D0DefLookup
+
+theorem d2DeltaRankFn_nat : d2DeltaRankFn ``Nat ≤ 0 := by decide
+
+theorem d2DeltaRankFn_natZero : d2DeltaRankFn ``Nat.zero ≤ 0 := by
+  decide
+
+theorem d2DeltaRankFn_natSucc : d2DeltaRankFn ``Nat.succ ≤ 0 := by
+  decide
+
+theorem d2DeltaRankFn_d0def :
+    d2DeltaRankFn ``ParamsD0.d0def ≤ 1 := by
+  decide
+
+theorem d2DeltaRankFn_d1mutB :
+    d2DeltaRankFn ``ParamsD1.d1mutB ≤ 2 := by
+  decide
+
+theorem d2NatCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.const ``Nat []) (.sort (.instV [] (.succ .zero))) true (n + 1) 0 := by
+  letI : Params := d2Params univs
+  intro Gamma n
+  exact .base (.const d2NatTypeLookup rfl d2DeltaRankFn_nat
+    (.base .sort'))
+
+theorem d2NatPiCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.forallE (.const ``Nat []) (.const ``Nat []))
+        (.sort (.imax (.instV [] (.succ .zero))
+          (.instV [] (.succ .zero)))) true (n + 2) 0 := by
+  letI : Params := d2Params univs
+  intro Gamma n
+  exact .base (.forallE (d2NatCertR univs Gamma n)
+    (d2NatCertR univs (_ :: Gamma) n))
+
+theorem d2SuccCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.const ``Nat.succ [])
+        (.forallE (.const ``Nat []) (.const ``Nat [])) true (n + 3) 0 := by
+  letI : Params := d2Params univs
+  intro Gamma n
+  exact .base (.const (d1Env_le_d2Env.constants d1NatSuccEnvLookup) rfl
+    d2DeltaRankFn_natSucc (d2NatPiCertR univs Gamma n))
+
+theorem d2ZeroCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.const ``Nat.zero []) (.const ``Nat []) true 2 0 := by
+  letI : Params := d2Params univs
+  intro Gamma
+  exact .base (.const (d1Env_le_d2Env.constants d1NatZeroEnvLookup) rfl
+    d2DeltaRankFn_natZero (d2NatCertR univs Gamma 0))
+
+theorem d2D0DefConstCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr) (n : Nat),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.const ``ParamsD0.d0def []) (.const ``Nat []) true (n + 2) 1 := by
+  letI : Params := d2Params univs
+  intro Gamma n
+  exact .base (.const d2D0DefLookup rfl d2DeltaRankFn_d0def
+    ((d2NatCertR univs Gamma n).mono_rank (Nat.zero_le 1)))
+
+theorem d2MutBValueCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.app (.const ``Nat.succ []) (.const ``ParamsD0.d0def []))
+        (.const ``Nat []) true 4 1 := by
+  letI : Params := d2Params univs
+  intro Gamma
+  refine .base (.app (u := .instV [] (.succ .zero))
+    (v := .instV [] (.succ .zero))
+    ((d2NatCertR univs Gamma 2).mono_rank (Nat.zero_le 1))
+    ((d2NatCertR univs (_ :: Gamma) 2).mono_rank (Nat.zero_le 1))
+    ((d2SuccCertR univs Gamma 0).mono_rank (Nat.zero_le 1))
+    (d2D0DefConstCertR univs Gamma 1)
+    ((d2NatCertR univs Gamma 2).mono_rank (Nat.zero_le 1)))
+
+theorem d2MutBConstCertR (univs : Nat) :
+    letI : Params := d2Params univs
+    ∀ (Gamma : List SExpr),
+      HasTypeStratifiedR d2DeltaRankFn Gamma
+        (.const ``ParamsD1.d1mutB []) (.const ``Nat []) true 2 2 := by
+  letI : Params := d2Params univs
+  intro Gamma
+  exact .base (.const (d1Env_le_d2Env.constants d1Env_d1MutB_lookup) rfl
+    d2DeltaRankFn_d1mutB
+    ((d2NatCertR univs Gamma 0).mono_rank (Nat.zero_le 2)))
+
+/-- The D2 fixture's checked δ-rank certificate.  The generated block rules
+are eliminated structurally because none has a constant pattern. -/
+def d2DeltaRank (univs : Nat) :
+    letI : Params := d2Params univs
+    Params.DeltaRank := by
+  letI : Params := d2Params univs
+  refine ⟨d2DeltaRankFn, ?_⟩
+  intro c ci value closed ls Gamma hpat hreg hlen
+  change D2Pat _ _ at hpat
+  have h1 := d2Pat_at_const hpat
+  cases h1 with
+  | old h0 =>
+    cases h0 with
+    | iota h => exact (natPat_no_const univs h).elim
+    | defn =>
+      obtain rfl := Option.some.inj (d2D0DefLookup.symm.trans hreg)
+      obtain rfl := List.length_eq_zero_iff.mp hlen
+      exact ⟨2, 0, by decide, d2ZeroCertR univs Gamma⟩
+  | defnA =>
+    obtain rfl := Option.some.inj
+      ((d1Env_le_d2Env.constants d1Env_d1MutA_lookup).symm.trans hreg)
+    obtain rfl := List.length_eq_zero_iff.mp hlen
+    exact ⟨2, 2, by decide, d2MutBConstCertR univs Gamma⟩
+  | defnB =>
+    obtain rfl := Option.some.inj
+      ((d1Env_le_d2Env.constants d1Env_d1MutB_lookup).symm.trans hreg)
+    obtain rfl := List.length_eq_zero_iff.mp hlen
+    exact ⟨4, 1, by decide, d2MutBValueCertR univs Gamma⟩
+
+/-! ## The parked block obligations
+
+Four obligations of the *block* half of `Params.Semantic` are not delivered
+here.  They are stated as named `Prop`s and bundled by the preferred premise
+`D2BlockStepExact`, so that every downstream statement carries them
+explicitly and the residual is exactly stated rather than described.  The
+earlier pair-shaped `D2BlockStep` remains as the internal assembler input;
+`D2BlockStepExact.toBlockStep` supplies its now-proved bookkeeping fields.
+
+Only the first is genuinely blocked: it is `L4L-18A′` strength.  The other
+three are mechanical per-rule volume which the generic engine deliberately
+takes as input — exactly as Theory's own generic block-rule soundness
+theorem takes its capture spine as a hypothesis.
+
+**Scope note.**  Capture-spine and β-collapse premises quantify over *every*
+iota rule of the D2 inventory, i.e. the block's five plus the two inherited
+`Nat` rules — not only the five new ones.  That is forced, not sloppy: a
+reduction-site certificate cannot be transported *downwards* along
+`d1Env ≤ d2Env`, because its inputs (`typing`, `matched`) are D2-instance
+derivations whose contexts and captures may mention the block's constants,
+and `d1StrongToD2` only runs in the growing direction.  D1 met exactly this
+and re-replayed D0's two `Nat` rules rather than transporting them
+(`SExprParamsD1.lean:1925-1929`); D2 would have to re-replay them a third
+time.  The two `Nat` checks are now discharged by `d2NatChecked`, and
+`D2CheckedStep.of_tree` lifts the five-entry `D2TreeCheckedStep` to the full
+inventory.  The genuinely 18A′-gated premise therefore quantifies over the
+five block rules only. -/
+
+/-- (i) The `Pattern.Check` discharge of a generated rule at a matched
+redex.  `TreeGen.ruleCheck` folds one `.defeq` per `treeDecl.nparams`; Tree
+has exactly one parameter and no indices, so this says: the
+constructor-side type parameter and the recursor-side type parameter of a
+matched redex are definitionally equal.  That is injectivity of a stuck
+inductive-type application, `L4L-18A′` strength — see
+`plans/probes/probeG-generic-instance.lean:320` (`iotaCheck_param`).  The
+semantic side cannot help: the logical relation realizes `indTy` arguments
+at `.bot` (`ShapeLogRel.lean:9244`), so it retains no argument information.
+This is the one genuinely blocked obligation. -/
+def D2CheckedStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List SExpr} {A majorTerm : SExpr}
+    {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr},
+    Params.Pat (RecursorIotaPattern rec major ctor arity) r →
+    Pattern.CaptureTyping Gamma mcap captureType →
+    D2ContextValid univs Gamma →
+    Pattern.IotaTyping Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A →
+    (RecursorIotaPattern rec major ctor arity).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs))) recLs mcap →
+    ∃ dfs : List (SExpr × SExpr × SExpr),
+      dfs.map (·.2) = r.2.defeqsS recLs mcap ∧
+      ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Gamma a b B
+
+/-- The inherited Nat rules contribute no check obligations: Nat has no
+parameters and no indices, so every generated `ruleCheck` is `.true`.
+This is independent of the surrounding D2 context and match. -/
+theorem d2NatChecked (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (H : NatPat (RecursorIotaPattern rec major ctor arity) r)
+    {Gamma : List (@SExpr (d2Params univs))}
+    {recLs : List (@SLevel (d2Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d2Params univs)} :
+    letI : Params := d2Params univs
+    ∃ dfs : List (SExpr × SExpr × SExpr),
+      dfs.map (·.2) = r.2.defeqsS recLs mcap ∧
+      ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Gamma a b B := by
+  letI : Params := d2Params univs
+  obtain ⟨i, constructor, hentry, hpattern, -⟩ :=
+    VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration H
+  change RecursorIotaPattern rec major ctor arity =
+    RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+      (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+      (NatGeneration.ruleArgArity constructor) at hpattern
+  obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+  let rgen :=
+    (NatGeneration.ruleRHS natRuleClosure hentry,
+      NatGeneration.ruleCheck natRuleClosure (List.mem_of_getElem? hentry))
+  have Hgen : NatPat
+      (RecursorIotaPattern (NatGeneration.ruleRecName constructor)
+        (NatGeneration.ruleMajorArity constructor) constructor.ctor.raw.name
+        (NatGeneration.ruleArgArity constructor)) rgen := .mk hentry
+  have hr : r ≍ rgen :=
+    (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+      H Hgen .refl (Pattern.inter_self _)).2.2
+  obtain rfl : r = rgen := eq_of_heq hr
+  have hi : i = 0 ∨ i = 1 := by
+    obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+    have : NatGeneration.flatCtors.length = 2 := rfl
+    omega
+  rcases hi with rfl | rfl
+  · have hc := Option.some.inj
+      (probeNatFlatCtorZero_lookup.symm.trans hentry)
+    subst constructor
+    exact ⟨[], by rfl, by simp⟩
+  · have hc := Option.some.inj
+      (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+    subst constructor
+    exact ⟨[], by rfl, by simp⟩
+
+/-- The genuinely blocked check contract, restricted to the five generated
+rules of the new block.  Unlike the earlier over-strong draft, the contract
+retains the concrete capture typing, valid context, typed recursor and
+constructor spines, and successful match from the reduction site. -/
+def D2TreeCheckedStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some constructor)
+    {Gamma : List SExpr} {A majorTerm : SExpr}
+    {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr}
+    {mcap : ((TreeGen.rulePattern constructor).toPattern).Path → SExpr}
+    {captureType : ((TreeGen.rulePattern constructor).toPattern).Path → SExpr},
+    Pattern.CaptureTyping Gamma mcap captureType →
+    D2ContextValid univs Gamma →
+    Pattern.IotaTyping Gamma (TreeGen.ruleRecName constructor)
+      constructor.ctor.raw.name recLs ctorLs recArgs ctorArgs majorTerm A →
+    ((TreeGen.rulePattern constructor).toPattern).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const (TreeGen.ruleRecName constructor) recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const constructor.ctor.raw.name ctorLs))) recLs mcap →
+    ∃ dfs : List (SExpr × SExpr × SExpr),
+      dfs.map (·.2) =
+        (TreeGen.ruleCheck treeRuleClosure
+          (List.mem_of_getElem? hentry)).defeqsS recLs mcap ∧
+      ∀ a b B, (B, a, b) ∈ dfs → IsDefEq Gamma a b B
+
+/-- Lift the five-rule block check to the complete D2 inventory.  The two
+Nat cases are discharged by `d2NatChecked`; definition extensions cannot
+inhabit a recursor-iota pattern. -/
+theorem D2CheckedStep.of_tree (univs : Nat)
+    (h : D2TreeCheckedStep univs) : D2CheckedStep univs := by
+  letI : Params := d2Params univs
+  intro rec major ctor arity r Gamma A majorTerm recLs ctorLs recArgs ctorArgs
+    mcap captureType hpat captureTyping hGamma typing matched
+  change D2Pat (RecursorIotaPattern rec major ctor arity) r at hpat
+  cases hpat with
+  | nat H =>
+    exact d2NatChecked univs H
+  | assembled H =>
+    rcases assembledPat_cases H with
+      ⟨i, c, hentry, hpattern, hr⟩ | ⟨ext, hmem, hpattern⟩
+    · change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (TreeGen.ruleRecName c)
+          (TreeGen.ruleMajorArity c) c.ctor.raw.name
+          (TreeGen.ruleArgArity c) at hpattern
+      obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+      obtain rfl : r = _ := eq_of_heq hr
+      exact h hentry captureTyping hGamma typing matched
+    · exfalso
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl <;>
+        exact absurd hpattern
+          (by simp [RecursorIotaPattern, d0DefExt, d1MutAExt, d1MutBExt])
+
+/-- (ii) The rule's capture inventory re-indexed onto its own binder
+telescope, with the rule's level arity.  The generic engine
+(`SExpr.iotaSiteOf`) consumes this and supplies every other site field;
+Theory's own generic block-rule soundness theorem takes the same spine as a
+hypothesis (`InductivePatternWF.lean`, the `hcaps` argument), so this is the
+engine's interface boundary rather than an omission.  It is mechanical
+per-rule volume: the recursor-spine peels plus the constructor's fields for
+the five block rules and the two inherited Nat rules.  The level-arity
+conjunct in this legacy form is proved unconditionally later by
+`d2IotaRule_levelsLength`; `D2CaptureSpineCoreStep` is the exact residual. -/
+def D2CaptureSpineStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List SExpr} {A majorTerm : SExpr}
+    {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    (rule : Pattern.IotaRule r),
+    D2ContextValid univs Gamma →
+    Pattern.IotaTyping Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A →
+    (RecursorIotaPattern rec major ctor arity).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs))) recLs mcap →
+    recLs.length = rule.df.uvars ∧
+      SpineWF Gamma (SExpr.mkInst recLs rule.df.type)
+        (rule.capturePaths.map mcap) A
+
+/-- (iii) The β-collapse of the rule's applied left tower back onto the
+matched redex.  Given (ii) this is `SExpr.ruleCollapse` plus a per-rule
+`instRev` computation and one type conversion; it is listed separately
+because that computation is per-rule. -/
+def D2CollapseStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List SExpr} {A majorTerm : SExpr}
+    {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    (rule : Pattern.IotaRule r),
+    D2ContextValid univs Gamma →
+    Pattern.IotaTyping Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A →
+    (RecursorIotaPattern rec major ctor arity).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs))) recLs mcap →
+    IsDefEq Gamma
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a)
+        (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs)))
+      ((rule.capturePaths.map mcap).foldl
+        (fun (f a : SExpr) => f.app a) (SExpr.mkInst recLs rule.df.lhs)) A
+
+/-- (iv) `Params.Semantic.registered` at the five block rules: the D0-style
+lambda-tower descent (`SExprParamsD0.lean:2898-5496`) re-run for this
+block. -/
+def D2RegisteredTowerStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {df : VDefEq} {ls : List SLevel} {Gamma : List SExpr},
+    df ∈ TreeGen.generatedRules → ls.length = df.uvars →
+    IsDefEqStrong Gamma (SExpr.mkInst ls df.lhs) (SExpr.mkInst ls df.rhs)
+      (SExpr.mkInst ls df.type)
+
+/-- The block half of the D2 semantic bridge, as one named premise.  Only
+`checked` is genuinely blocked (`L4L-18A′`); the other three are mechanical
+per-rule volume that the generic engine deliberately takes as input. -/
+structure D2BlockStep (univs : Nat) : Prop where
+  checked : D2TreeCheckedStep univs
+  captureSpine : D2CaptureSpineStep univs
+  lhsCollapse : D2CollapseStep univs
+  registeredTower : D2RegisteredTowerStep univs
+
+/-- The complete `Params.Semantic.iotaSite` for the D2 inventory, assembled
+by the generic engine `SExpr.iotaSiteOf` from the parked block data. -/
+noncomputable def d2IotaSite (univs : Nat) (h : D2BlockStep univs)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d2Params univs))}
+    {A majorTerm : @SExpr (d2Params univs)}
+    {recLs ctorLs : List (@SLevel (d2Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d2Params univs))}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d2Params univs)}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r)
+    (captureType : (RecursorIotaPattern rec major ctor arity).Path →
+      @SExpr (d2Params univs))
+    (captureTyping : @Pattern.CaptureTyping (d2Params univs) Gamma
+      (RecursorIotaPattern rec major ctor arity) mcap captureType)
+    (hGamma : D2ContextValid univs Gamma)
+    (typing : @Pattern.IotaTyping (d2Params univs) Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A)
+    (matched : @Pattern.MatchesS (d2Params univs)
+      (RecursorIotaPattern rec major ctor arity)
+      (@SExpr.app (d2Params univs)
+        (recArgs.foldr (fun a f => @SExpr.app (d2Params univs) f a)
+          (@SExpr.const (d2Params univs) rec recLs))
+        (ctorArgs.foldr (fun a f => @SExpr.app (d2Params univs) f a)
+          (@SExpr.const (d2Params univs) ctor ctorLs))) recLs mcap) :
+    @Pattern.IotaReductionSite (d2Params univs) Gamma rec major ctor
+      arity r rule recLs ctorLs recArgs ctorArgs majorTerm A mcap captureType
+      captureTyping := by
+  letI : Params := d2Params univs
+  have hcap := h.captureSpine rule hGamma typing matched
+  have hchecked : D2CheckedStep univs :=
+    D2CheckedStep.of_tree univs h.checked
+  have hck := hchecked rule.pat captureTyping hGamma typing matched
+  exact SExpr.iotaSiteOf (d2Replay univs) rule captureTyping hGamma typing
+    matched hcap.1 hcap.2 (h.lhsCollapse rule hGamma typing matched)
+    hck.choose hck.choose_spec.1 hck.choose_spec.2
+
+/-- `Params.Semantic.registered` for the complete D2 inventory. -/
+theorem d2Registered (univs : Nat) (h : D2BlockStep univs)
+    {df : VDefEq} {ls : List (@SLevel (d2Params univs))}
+    {Gamma : List (@SExpr (d2Params univs))}
+    (hreg : d2Env.defeqs df) (hlen : ls.length = df.uvars)
+    (_hLhs : @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.mkInst (d2Params univs) ls df.lhs)
+      (@SExpr.mkInst (d2Params univs) ls df.lhs)
+      (@SExpr.mkInst (d2Params univs) ls df.type))
+    (_hRhs : @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.mkInst (d2Params univs) ls df.rhs)
+      (@SExpr.mkInst (d2Params univs) ls df.rhs)
+      (@SExpr.mkInst (d2Params univs) ls df.type)) :
+    @IsDefEqStrong (d2Params univs) Gamma
+      (@SExpr.mkInst (d2Params univs) ls df.lhs)
+      (@SExpr.mkInst (d2Params univs) ls df.rhs)
+      (@SExpr.mkInst (d2Params univs) ls df.type) := by
+  rw [d2Env_defeqs_iff] at hreg
+  rcases hreg with hnew | hold
+  · exact h.registeredTower hnew hlen
+  · exact d2Registered_old univs hold hlen
+
+/-- The complete D2 bridge, conditional on the block step: the inherited
+Nat iota rules, the three inherited definition rules, the block's five
+constructor bundles, and the block's five generated iota rules. -/
+noncomputable def d2Semantic (univs : Nat) (h : D2BlockStep univs) :
+    letI : Params := d2Params univs
+    Params.Semantic := by
+  letI : Params := d2Params univs
+  exact {
+  structureEta := by
+    intro rule levels Gamma params major hreg
+    exact (d2Env_no_structEta rule hreg).elim
+  ctor := by
+    intro c ci ls Gamma hci hlen cl
+    exact d2Ctor univs hci hlen cl
+  defn := by
+    intro c r hpat
+    exact d2Defn univs hpat
+  iotaRule := by
+    intro rec major ctor arity r hpat
+    exact d2IotaRule univs hpat
+  iotaSite := by
+    intro rec major ctor arity r Gamma A majorTerm recLs ctorLs
+      recArgs ctorArgs mcap rule captureType captureTyping hGamma typing
+      matched _redexSelf _AType
+    exact d2IotaSite univs h rule captureType captureTyping hGamma typing
+      matched
+  registered := by
+    intro df ls Gamma hreg hlen hLhs hRhs
+    exact d2Registered univs h hreg hlen hLhs hRhs }
+
+/-- End-to-end D2 endpoint, conditional on the block step: the
+block-inductive environment supplies every semantic certificate required by
+the experimental sort-injectivity bridge. -/
+theorem d2SortInvS (univs : Nat) (h : D2BlockStep univs)
+    {Gamma : List VExpr} {u v : VLevel}
+    (hGamma : OnCtx Gamma (d2Env.IsType univs))
+    (hde : d2Env.IsDefEqU univs Gamma (.sort u) (.sort v)) : u ≈ v := by
+  letI : Params := d2Params univs
+  letI : Params.Semantic := d2Semantic univs h
+  exact VEnv.IsDefEqU.sort_invS hGamma hde
+
+/-! ## The complete rule registry, disambiguated by right towers
+
+Every site-level case analysis below must recover *which* registered rule a
+matched descriptor names.  D1 did this with per-pair `rhs`-inequality
+probes; the D2 inventory has ten registered rules, so the pairwise style
+would need dozens of probes.  Instead the registry is pinned once: the ten
+rules' right towers are pairwise distinct, so a registered defeq is
+recovered from its `rhs` alone. -/
+
+/-- The complete defeq inventory of `d2Env`, in registration order: the
+block's five generated rules, the three definition rules, and the two
+inherited `Nat` rules. -/
+def d2AllRules : List VDefEq :=
+  TreeGen.generatedRules ++
+    [d1MutBVal.toDefEq, d1MutAVal.toDefEq, d0DefVal.toDefEq] ++
+    NatGeneration.generatedRules
+
+theorem d2Env_defeqs_mem {df : VDefEq} :
+    d2Env.defeqs df ↔ df ∈ d2AllRules := by
+  rw [d2Env_defeqs_iff, d1Env_defeqs_iff, d0Env_defeqs_iff,
+    natFinalEnv_defeqs_iff]
+  simp only [d2AllRules, List.mem_append, List.mem_cons, List.not_mem_nil,
+    or_false, or_assoc]
+
+/-- The ten registered right towers are pairwise distinct. -/
+theorem d2AllRules_rhs_nodup : (d2AllRules.map (·.rhs)).Nodup := by
+  native_decide
+
+private theorem map_nodup_inj {α β : Type _} {f : α → β} :
+    ∀ {l : List α}, (l.map f).Nodup → ∀ {a b : α}, a ∈ l → b ∈ l →
+      f a = f b → a = b
+  | [], _, _, _, ha, _, _ => (List.not_mem_nil ha).elim
+  | x :: l, hnodup, a, b, ha, hb, hf => by
+    rw [List.map_cons, List.nodup_cons] at hnodup
+    cases List.mem_cons.mp ha with
+    | inl haeq =>
+      cases List.mem_cons.mp hb with
+      | inl hbeq => rw [haeq, hbeq]
+      | inr hbmem =>
+        have hmem : f b ∈ l.map f := List.mem_map_of_mem hbmem
+        rw [← hf, haeq] at hmem
+        exact absurd hmem hnodup.1
+    | inr hamem =>
+      cases List.mem_cons.mp hb with
+      | inl hbeq =>
+        have hmem : f a ∈ l.map f := List.mem_map_of_mem hamem
+        rw [hf, hbeq] at hmem
+        exact absurd hmem hnodup.1
+      | inr hbmem => exact map_nodup_inj hnodup.2 hamem hbmem hf
+
+/-- A registered defeq of `d2Env` is recovered from its right tower. -/
+theorem d2Registered_eq_of_rhs {df target : VDefEq}
+    (hreg : d2Env.defeqs df) (htarget : target ∈ d2AllRules)
+    (hrhs : df.rhs = target.rhs) : df = target :=
+  map_nodup_inj d2AllRules_rhs_nodup (d2Env_defeqs_mem.mp hreg) htarget hrhs
+
+/-- A D2 iota descriptor is uniquely determined by its pattern payload.
+
+The payload fixes the registered right tower.  Pairwise distinct right
+towers then identify the registered equation, and injectivity of a
+fixed-headed `RHS.appN` identifies the ordered capture paths.  This removes
+the proof-relevant descriptor choice from every subsequent replay: a caller
+may replace an arbitrary `Pattern.IotaRule r` by the canonical descriptor
+returned by `d2IotaRule`. -/
+theorem d2IotaRule_ext (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (x y : @Pattern.IotaRule (d2Params univs) rec major ctor arity r) :
+    x = y := by
+  letI : Params := d2Params univs
+  rcases x with ⟨xpat, xdf, xreg, xclosed, xpaths, xtower⟩
+  rcases y with ⟨ypat, ydf, yreg, yclosed, ypaths, ytower⟩
+  obtain ⟨hrhs, hpaths⟩ := rhsFixedAppN_inj (xtower.symm.trans ytower)
+  have hdf : xdf = ydf :=
+    d2Registered_eq_of_rhs xreg (d2Env_defeqs_mem.mp yreg) hrhs
+  subst ydf
+  subst ypaths
+  rfl
+
+instance d2IotaRule_subsingleton (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check} :
+    Subsingleton (@Pattern.IotaRule (d2Params univs)
+      rec major ctor arity r) :=
+  ⟨d2IotaRule_ext univs⟩
+
+/-- Replace an arbitrary descriptor by the public canonical choice for its
+own pattern proof. -/
+theorem d2IotaRule_eq_canonical (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r) :
+    rule = d2IotaRule univs (by
+      letI : Params := d2Params univs
+      exact rule.pat) :=
+  d2IotaRule_ext univs _ _
+
+/-- Recover the canonical origin of any D2 iota descriptor.
+
+The result has seven concrete leaves: the left disjunct contains the two
+inherited Nat rules, while the right disjunct contains the five entries of
+`TreeGen.flatCtors`.  `HEq` in the block branch carries the recovered
+recursor, major arity, constructor, argument arity, and payload indices in
+one equation, so downstream replay can eliminate it without a registry
+cross-product. -/
+theorem d2IotaRule_origin (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r) :
+    (∃ H : NatPat (RecursorIotaPattern rec major ctor arity) r,
+      rule = d2NatIotaRule univs H) ∨
+    (∃ (i : Nat) (constructor : NormalizedBlockCtor)
+        (hentry : TreeGen.flatCtors[i]? = some constructor),
+      HEq rule (d2TreeIotaRule univs hentry)) := by
+  letI : Params := d2Params univs
+  have hpat := rule.pat
+  change D2Pat (RecursorIotaPattern rec major ctor arity) r at hpat
+  cases hpat with
+  | nat H =>
+    exact .inl ⟨H, d2IotaRule_ext univs _ _⟩
+  | assembled H =>
+    rcases assembledPat_cases H with
+      ⟨i, c, hentry, hpattern, hr⟩ | ⟨ext, hmem, hpattern⟩
+    · change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (TreeGen.ruleRecName c)
+          (TreeGen.ruleMajorArity c) c.ctor.raw.name
+          (TreeGen.ruleArgArity c) at hpattern
+      obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+      obtain rfl : r = _ := eq_of_heq hr
+      exact .inr ⟨i, c, hentry,
+        heq_of_eq (d2IotaRule_ext univs _ _)⟩
+    · exfalso
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl <;>
+        exact absurd hpattern
+          (by simp [RecursorIotaPattern, d0DefExt, d1MutAExt, d1MutBExt])
+
+/-- Seven-case elimination for D2 iota descriptors.  All proof-relevant
+descriptor fields have already been canonicalized by
+`d2IotaRule_origin`; callers prove only the Nat-family and block-entry
+cases. -/
+theorem d2IotaRule_elim (univs : Nat)
+    (P : ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check},
+      @Pattern.IotaRule (d2Params univs) rec major ctor arity r → Prop)
+    (hnat : ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      (H : NatPat (RecursorIotaPattern rec major ctor arity) r),
+      P (d2NatIotaRule univs H))
+    (htree : ∀ {i : Nat} {constructor : NormalizedBlockCtor}
+      (hentry : TreeGen.flatCtors[i]? = some constructor),
+      P (d2TreeIotaRule univs hentry))
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r) :
+    P rule := by
+  letI : Params := d2Params univs
+  have hpat := rule.pat
+  change D2Pat (RecursorIotaPattern rec major ctor arity) r at hpat
+  cases hpat with
+  | nat H =>
+    rw [d2IotaRule_ext univs rule (d2NatIotaRule univs H)]
+    exact hnat H
+  | assembled H =>
+    rcases assembledPat_cases H with
+      ⟨i, c, hentry, hpattern, hr⟩ | ⟨ext, hmem, hpattern⟩
+    · change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (TreeGen.ruleRecName c)
+          (TreeGen.ruleMajorArity c) c.ctor.raw.name
+          (TreeGen.ruleArgArity c) at hpattern
+      obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+      obtain rfl : r = _ := eq_of_heq hr
+      rw [d2IotaRule_ext univs rule (d2TreeIotaRule univs hentry)]
+      exact htree hentry
+    · exfalso
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl <;>
+        exact absurd hpattern
+          (by simp [RecursorIotaPattern, d0DefExt, d1MutAExt, d1MutBExt])
+
+/-- Fully concrete seven-entry elimination.  Unlike `d2IotaRule_elim`, the
+Nat branch is indexed by its generated-rule lookup too, so every descriptor
+field reduces to literal `NatGeneration`/`TreeGen` data. -/
+theorem d2IotaRule_entry_elim (univs : Nat)
+    (P : ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check},
+      @Pattern.IotaRule (d2Params univs) rec major ctor arity r → Prop)
+    (hnat : ∀ {i : Nat} {constructor : NormalizedBlockCtor}
+      (hentry : NatGeneration.flatCtors[i]? = some constructor),
+      P (d2NatEntryIotaRule univs hentry))
+    (htree : ∀ {i : Nat} {constructor : NormalizedBlockCtor}
+      (hentry : TreeGen.flatCtors[i]? = some constructor),
+      P (d2TreeIotaRule univs hentry))
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r) :
+    P rule := by
+  letI : Params := d2Params univs
+  have hpat := rule.pat
+  change D2Pat (RecursorIotaPattern rec major ctor arity) r at hpat
+  cases hpat with
+  | nat H =>
+    obtain ⟨i, c, hentry, hpattern, -⟩ :=
+      VInductDecl.BlockGenerationChecked.IotaPat.recover NatGeneration H
+    change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (NatGeneration.ruleRecName c)
+          (NatGeneration.ruleMajorArity c) c.ctor.raw.name
+          (NatGeneration.ruleArgArity c) at hpattern
+    obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+    let rgen :=
+      (NatGeneration.ruleRHS natRuleClosure hentry,
+        NatGeneration.ruleCheck natRuleClosure
+          (List.mem_of_getElem? hentry))
+    have Hgen : NatPat
+        (RecursorIotaPattern (NatGeneration.ruleRecName c)
+          (NatGeneration.ruleMajorArity c) c.ctor.raw.name
+          (NatGeneration.ruleArgArity c)) rgen := .mk hentry
+    have hr : r ≍ rgen :=
+      (VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq NatGeneration
+        H Hgen .refl (Pattern.inter_self _)).2.2
+    obtain rfl : r = rgen := eq_of_heq hr
+    rw [d2IotaRule_ext univs rule (d2NatEntryIotaRule univs hentry)]
+    exact hnat hentry
+  | assembled H =>
+    rcases assembledPat_cases H with
+      ⟨i, c, hentry, hpattern, hr⟩ | ⟨ext, hmem, hpattern⟩
+    · change RecursorIotaPattern rec major ctor arity =
+        RecursorIotaPattern (TreeGen.ruleRecName c)
+          (TreeGen.ruleMajorArity c) c.ctor.raw.name
+          (TreeGen.ruleArgArity c) at hpattern
+      obtain ⟨rfl, rfl, rfl, rfl⟩ := RecursorIotaPattern.inj hpattern
+      obtain rfl : r = _ := eq_of_heq hr
+      rw [d2IotaRule_ext univs rule (d2TreeIotaRule univs hentry)]
+      exact htree hentry
+    · exfalso
+      simp only [d2Exts, List.mem_cons, List.not_mem_nil, or_false] at hmem
+      rcases hmem with rfl | rfl | rfl <;>
+        exact absurd hpattern
+          (by simp [RecursorIotaPattern, d0DefExt, d1MutAExt, d1MutBExt])
+
+/-- The recursor levels at every D2 iota site have the arity stored by the
+selected generated equation.  This field is not per-rule replay volume: it
+comes from the typed recursor head and the generated rule's `rule_uvars`
+identity. -/
+theorem d2IotaRule_levelsLength (univs : Nat)
+    {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List (@SExpr (d2Params univs))} {A majorTerm : @SExpr (d2Params univs)}
+    {recLs ctorLs : List (@SLevel (d2Params univs))}
+    {recArgs ctorArgs : List (@SExpr (d2Params univs))}
+    (rule : @Pattern.IotaRule (d2Params univs) rec major ctor arity r)
+    (typing : @Pattern.IotaTyping (d2Params univs) Gamma rec ctor recLs
+      ctorLs recArgs ctorArgs majorTerm A) :
+    letI : Params := d2Params univs
+    recLs.length = rule.df.uvars := by
+  letI : Params := d2Params univs
+  let P : ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check},
+      @Pattern.IotaRule (d2Params univs) rec major ctor arity r → Prop :=
+    fun {rec} {_major} {ctor} {_arity} {_r} selected =>
+      ∀ {Gamma : List SExpr} {A majorTerm : SExpr}
+        {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr},
+        Pattern.IotaTyping Gamma rec ctor recLs ctorLs
+          recArgs ctorArgs majorTerm A →
+        recLs.length = selected.df.uvars
+  have hP : P rule := by
+    apply d2IotaRule_entry_elim univs P
+    · intro i constructor hentry Gamma A majorTerm recLs ctorLs recArgs
+        ctorArgs typing
+      have hi : i = 0 ∨ i = 1 := by
+        obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+        have : NatGeneration.flatCtors.length = 2 := rfl
+        omega
+      rcases hi with rfl | rfl
+      all_goals
+        first
+        | have hc := Option.some.inj
+            (probeNatFlatCtorZero_lookup.symm.trans hentry)
+        | have hc := Option.some.inj
+            (probeNatFlatCtorSucc_lookup.symm.trans hentry)
+        subst constructor
+        have hlen := typing.recHead.const_left_levelsLength
+          (d1Env_le_d2Env.constants d1NatRecEnvLookup)
+        change recLs.length = 1 at hlen
+        change recLs.length = (NatGeneration.rule _ _).uvars
+        change recLs.length = 1
+        exact hlen
+    · intro i constructor hentry Gamma A majorTerm recLs ctorLs recArgs
+        ctorArgs typing
+      have hi : i = 0 ∨ i = 1 ∨ i = 2 ∨ i = 3 ∨ i = 4 := by
+        obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.mp hentry
+        have : TreeGen.flatCtors.length = 5 := rfl
+        omega
+      rcases hi with rfl | rfl | rfl | rfl | rfl
+      all_goals
+        first
+        | have hc := Option.some.inj
+            ((show TreeGen.flatCtors[0]? = some TreeGen.flatCtors[0] from rfl).symm.trans
+              hentry)
+        | have hc := Option.some.inj
+            ((show TreeGen.flatCtors[1]? = some TreeGen.flatCtors[1] from rfl).symm.trans
+              hentry)
+        | have hc := Option.some.inj
+            ((show TreeGen.flatCtors[2]? = some TreeGen.flatCtors[2] from rfl).symm.trans
+              hentry)
+        | have hc := Option.some.inj
+            ((show TreeGen.flatCtors[3]? = some TreeGen.flatCtors[3] from rfl).symm.trans
+              hentry)
+        | have hc := Option.some.inj
+            ((show TreeGen.flatCtors[4]? = some TreeGen.flatCtors[4] from rfl).symm.trans
+              hentry)
+        subst constructor
+      case inl | inr.inl | inr.inr.inl =>
+        have hlen :=
+          typing.recHead.const_left_levelsLength d2Env_treeRec_lookup
+        change recLs.length = 2 at hlen
+        change recLs.length = (TreeGen.rule _ _).uvars
+        change recLs.length = 2
+        exact hlen
+      case inr.inr.inr.inl | inr.inr.inr.inr =>
+        have hlen :=
+          typing.recHead.const_left_levelsLength d2Env_treeListRec_lookup
+        change recLs.length = 2 at hlen
+        change recLs.length = (TreeGen.rule _ _).uvars
+        change recLs.length = 2
+        exact hlen
+  exact hP typing
+
+/-- The actual per-rule capture obligation after removing the universe-arity
+field proved by `d2IotaRule_levelsLength`. -/
+def D2CaptureSpineCoreStep (univs : Nat) : Prop :=
+  letI : Params := d2Params univs
+  ∀ {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {Gamma : List SExpr} {A majorTerm : SExpr}
+    {recLs ctorLs : List SLevel} {recArgs ctorArgs : List SExpr}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    (rule : Pattern.IotaRule r),
+    D2ContextValid univs Gamma →
+    Pattern.IotaTyping Gamma rec ctor recLs ctorLs
+      recArgs ctorArgs majorTerm A →
+    (RecursorIotaPattern rec major ctor arity).MatchesS
+      ((recArgs.foldr (fun (a f : SExpr) => f.app a) (SExpr.const rec recLs)).app
+        (ctorArgs.foldr (fun (a f : SExpr) => f.app a)
+          (SExpr.const ctor ctorLs))) recLs mcap →
+    SpineWF Gamma (SExpr.mkInst recLs rule.df.type)
+      (rule.capturePaths.map mcap) A
+
+/-- Restore the legacy pair-shaped capture contract from its genuine spine
+content and the unconditional level-arity theorem. -/
+theorem D2CaptureSpineStep.of_core (univs : Nat)
+    (h : D2CaptureSpineCoreStep univs) : D2CaptureSpineStep univs := by
+  letI : Params := d2Params univs
+  intro rec major ctor arity r Gamma A majorTerm recLs ctorLs recArgs ctorArgs
+    mcap rule hGamma typing matched
+  exact ⟨d2IotaRule_levelsLength univs rule typing,
+    h rule hGamma typing matched⟩
+
+/-- The exact remaining D2 bridge contract.
+
+Compared with the internal `D2BlockStep`, this removes both obligations now
+proved by the fixture itself: inherited Nat checks and recursor level arity.
+Its four fields are therefore the five-rule 18A′ check, the seven-rule
+capture spine, the seven-rule β-collapse, and the five generated strong
+towers. -/
+structure D2BlockStepExact (univs : Nat) : Prop where
+  checked : D2TreeCheckedStep univs
+  captureSpine : D2CaptureSpineCoreStep univs
+  lhsCollapse : D2CollapseStep univs
+  registeredTower : D2RegisteredTowerStep univs
+
+theorem D2BlockStepExact.toBlockStep (h : D2BlockStepExact univs) :
+    D2BlockStep univs where
+  checked := h.checked
+  captureSpine := D2CaptureSpineStep.of_core univs h.captureSpine
+  lhsCollapse := h.lhsCollapse
+  registeredTower := h.registeredTower
+
+/-- Preferred complete semantic bridge, conditional only on the exact
+residual contract. -/
+noncomputable def d2SemanticExact (univs : Nat) (h : D2BlockStepExact univs) :
+    letI : Params := d2Params univs
+    Params.Semantic :=
+  d2Semantic univs h.toBlockStep
+
+/-- Preferred D2 endpoint with inherited Nat checks and all level-arity
+bookkeeping discharged internally. -/
+theorem d2SortInvSExact (univs : Nat) (h : D2BlockStepExact univs)
+    {Gamma : List VExpr} {u v : VLevel}
+    (hGamma : OnCtx Gamma (d2Env.IsType univs))
+    (hde : d2Env.IsDefEqU univs Gamma (.sort u) (.sort v)) : u ≈ v :=
+  d2SortInvS univs h.toBlockStep hGamma hde
+
+/-! ## Endpoints and pins -/
+
+/-- The block-extended environment is well formed, ordered, and registers
+exactly the block's generated rules over D1's. -/
+theorem d2Env_live :
+    d2Env.WF ∧ d2Env.Ordered ∧
+      ∀ df, d2Env.defeqs df ↔
+        df ∈ TreeGen.generatedRules ∨ d1Env.defeqs df :=
+  ⟨d2Env_wf, d2Env_ordered, d2Env_defeqs_iff⟩
+
+/-! ## What remains for the D2 `Params.Semantic` bridge
+
+**Corrected record.**  Four of the six `Params.Semantic` fields are now
+delivered unconditionally: `structureEta` (`d2StructureEtaSound`),
+`iotaRule` (`d2IotaRule`), `ctor` (`d2Ctor`, including all five block
+constructor bundles) and `defn` (`d2Defn`).  `registered` is delivered for
+every inherited rule (`d2Registered_old`).  What remains is the *block*
+half of `iotaSite` and `registered`, packaged by the single preferred premise
+`D2BlockStepExact`; `d2SemanticExact`/`d2SortInvSExact` are conditional on
+exactly that premise and nothing else.  Descriptor uniqueness and
+`d2IotaRule_entry_elim` reduce arbitrary proof-relevant descriptors to the
+seven literal generated entries.  The inherited Nat check branches and the
+recursor level-arity field are proved outright and do not appear in the
+preferred premise.
+
+The earlier record here called the residual "pure volume".  That is
+**wrong** for one of its four components:
+
+* `D2TreeCheckedStep` is *not* volume.  `TreeGen.ruleCheck` folds one `.defeq`
+  per `treeDecl.nparams`, and Tree has one parameter, so discharging it at
+  a matched redex means deriving `p ≡ a` from a stuck `I p ≡ I a`.  That is
+  injectivity of a stuck inductive-type application — `L4L-18A′` strength,
+  the same wall recorded for the quotient rule at
+  `SExprParamsD1.lean:2735`.  The semantic side cannot supply it either:
+  the logical relation realizes `indTy` arguments at `.bot`
+  (`ShapeLogRel.lean:9244`), so it retains no argument information at all.
+  D0/D1 never met this wall because `Nat` has no parameters and no indices,
+  which is why both discharge `checked` by `simp`.
+
+* `D2CaptureSpineCoreStep`, `D2CollapseStep` and
+  `D2RegisteredTowerStep` *are*
+  volume, but far less of it than the old note claimed, because the
+  rule-independent part has been factored out into the generic engine
+  `Lean4Lean/Experimental/SExprGenericReplay.lean`
+  (`SExpr.ruleCollapse`, `SExpr.iotaSiteOf`) and the syntax transport into
+  `Lean4Lean/Experimental/SExprTransport.lean`.  Notably `ruleCollapse` —
+  the whole reify/`instL_lamN`/`lamN_wf`/`retarget`/`appN_lamN`/`mkS`
+  chain that D0 and D1 inline once per rule — is proved once, generically,
+  and is `sorryAx`-free.  Theory's own generic block-rule soundness theorem
+  takes the capture spine as a hypothesis for the same reason this engine
+  does, so `D2CaptureSpineCoreStep` marks an interface boundary, not an
+  omission.
+
+The old note also claimed the D1→D2 transport functor was missing; it is
+now landed (`d1StrongToD2` and the generic transport it rests on), which is
+what unblocked `ctor`/`defn`.
+
+The two forcing observations below are unchanged in content: every
+generated rule of the live block is simultaneously a `Pat` member and a
+registered defeq of `d2Env`, which is what obliges `iotaSite`/`registered`
+at it, hence what `D2BlockStepExact` must cover. -/
+
+/-- Forcing observation 1: every generated rule of the live block is a
+pattern member of the D2 registry.  This is what makes `D2TreeCheckedStep`
+unavoidable: the pattern's `Check` payload is `TreeGen.ruleCheck`, whose
+parameter obligation is 18A′-gated. -/
+theorem d2Pat_block_rule {i : Nat} {c : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some c) :
+    D2Pat ((TreeGen.rulePattern c).toPattern)
+      (TreeGen.ruleRHS treeRuleClosure hentry,
+        TreeGen.ruleCheck treeRuleClosure (List.mem_of_getElem? hentry)) :=
+  .assembled (.rule (.mk hentry))
+
+/-- Forcing observation 2: the same rule is a registered defeq of the live
+environment, so `Params.Semantic.registered` is obliged at it. -/
+theorem d2Registered_obligation {i : Nat} {c : NormalizedBlockCtor}
+    (hentry : TreeGen.flatCtors[i]? = some c) :
+    d2Env.defeqs (TreeGen.rule i c) ∧
+      D2Pat ((TreeGen.rulePattern c).toPattern)
+        (TreeGen.ruleRHS treeRuleClosure hentry,
+          TreeGen.ruleCheck treeRuleClosure (List.mem_of_getElem? hentry)) :=
+  ⟨treeRule_registered hentry, d2Pat_block_rule hentry⟩
+
+/-! ## Axiom closures
+
+The pattern layer — including all four union-level non-overlap laws, this
+file's first live consumption of `Theory/Typing/InductivePatternEnv.lean` —
+stays on the standard logical baseline with kernel `decide` only.  The
+environment layer inherits D1's named concrete `native_decide` freshness
+observations and adds three of its own; it carries no `sorryAx`, so the live
+block-inductive environment is admission-free. -/
+
+/-- info: 'Lean4Lean.SExpr.ParamsD2.d2ExtSeparation' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms d2ExtSeparation
+
+/-- info: 'Lean4Lean.SExpr.ParamsD2.d2Pat_uniq' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms d2Pat_uniq
+
+/-- info: 'Lean4Lean.SExpr.ParamsD2.d2Pat_app_l_uniq' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms d2Pat_app_l_uniq
+
+/-- info: 'Lean4Lean.SExpr.ParamsD2.d2Pat_app_uniq' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms d2Pat_app_uniq
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Env_wf' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Env_wf
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Params' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Params
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2StructureEtaSound' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2StructureEtaSound
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2IotaRule' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2IotaRule
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Registered_obligation' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ d2Env_isSome._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Registered_obligation
+
+/-! ### New pins: the semantic layer landed by this slice
+
+`d2Ctor` and `d2Defn` are unconditional.  `d2Semantic`/`d2SortInvS` and
+their preferred exact-contract wrappers are conditional on the corresponding
+D2 block premise and inherit the ladder's existing `sorryAx` through
+`VEnv.IsDefEq.uniq` (the 16C′ leaf that `SExprParamsD1.lean:2654` already
+carries); they introduce no new admission of their own.  The descriptor
+uniqueness and level-arity mechanics added with the exact contract are
+`sorryAx`-free. -/
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Ctor' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ d1Classify_tree._native.native_decide.ax_1_1,
+ d1Classify_treeBranch._native.native_decide.ax_1_1,
+ d1Classify_treeLeaf._native.native_decide.ax_1_1,
+ d1Classify_treeList._native.native_decide.ax_1_1,
+ d1Classify_treeListCons._native.native_decide.ax_1_1,
+ d1Classify_treeListNil._native.native_decide.ax_1_1,
+ d1Classify_treeListRec._native.native_decide.ax_1_1,
+ d1Classify_treeNode._native.native_decide.ax_1_1,
+ d1Classify_treeRec._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeBranch_fresh._native.native_decide.ax_1_1,
+ treeLeaf_fresh._native.native_decide.ax_1_1,
+ treeListCons_fresh._native.native_decide.ax_1_1,
+ treeListNil_fresh._native.native_decide.ax_1_1,
+ treeListRec_fresh._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ treeNode_fresh._native.native_decide.ax_1_1,
+ treeRec_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Ctor
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Defn' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeBranch_fresh._native.native_decide.ax_1_1,
+ treeLeaf_fresh._native.native_decide.ax_1_1,
+ treeListCons_fresh._native.native_decide.ax_1_1,
+ treeListNil_fresh._native.native_decide.ax_1_1,
+ treeListRec_fresh._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ treeNode_fresh._native.native_decide.ax_1_1,
+ treeRec_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Defn
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2Semantic' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_3,
+ probeNatGeneratedRuleSucc_lookup._native.native_decide.ax_1_1,
+ probeNatGeneratedRuleZero_lookup._native.native_decide.ax_1_1,
+ probeNatRecTypeV_eq._native.native_decide.ax_1_1,
+ probeNatRuleRhs_ne._native.native_decide.ax_1_1,
+ probeNatSuccCtorName._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleRecName._native.native_decide.ax_1_1,
+ probeNatSuccRuleTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ probeNatZeroCtorName._native.native_decide.ax_1_1,
+ probeNatZeroRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatZeroRuleRecName._native.native_decide.ax_1_1,
+ probeNatZeroRuleTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_3,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_3,
+ d1Classify_tree._native.native_decide.ax_1_1,
+ d1Classify_treeBranch._native.native_decide.ax_1_1,
+ d1Classify_treeLeaf._native.native_decide.ax_1_1,
+ d1Classify_treeList._native.native_decide.ax_1_1,
+ d1Classify_treeListCons._native.native_decide.ax_1_1,
+ d1Classify_treeListNil._native.native_decide.ax_1_1,
+ d1Classify_treeListRec._native.native_decide.ax_1_1,
+ d1Classify_treeNode._native.native_decide.ax_1_1,
+ d1Classify_treeRec._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeBranch_fresh._native.native_decide.ax_1_1,
+ treeLeaf_fresh._native.native_decide.ax_1_1,
+ treeListCons_fresh._native.native_decide.ax_1_1,
+ treeListNil_fresh._native.native_decide.ax_1_1,
+ treeListRec_fresh._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ treeNode_fresh._native.native_decide.ax_1_1,
+ treeRec_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2Semantic
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2SortInvS' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_3,
+ probeNatGeneratedRuleSucc_lookup._native.native_decide.ax_1_1,
+ probeNatGeneratedRuleZero_lookup._native.native_decide.ax_1_1,
+ probeNatRecTypeV_eq._native.native_decide.ax_1_1,
+ probeNatRuleRhs_ne._native.native_decide.ax_1_1,
+ probeNatSuccCtorName._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleRecName._native.native_decide.ax_1_1,
+ probeNatSuccRuleTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ probeNatZeroCtorName._native.native_decide.ax_1_1,
+ probeNatZeroRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatZeroRuleRecName._native.native_decide.ax_1_1,
+ probeNatZeroRuleTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_3,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_3,
+ d1Classify_tree._native.native_decide.ax_1_1,
+ d1Classify_treeBranch._native.native_decide.ax_1_1,
+ d1Classify_treeLeaf._native.native_decide.ax_1_1,
+ d1Classify_treeList._native.native_decide.ax_1_1,
+ d1Classify_treeListCons._native.native_decide.ax_1_1,
+ d1Classify_treeListNil._native.native_decide.ax_1_1,
+ d1Classify_treeListRec._native.native_decide.ax_1_1,
+ d1Classify_treeNode._native.native_decide.ax_1_1,
+ d1Classify_treeRec._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeBranch_fresh._native.native_decide.ax_1_1,
+ treeLeaf_fresh._native.native_decide.ax_1_1,
+ treeListCons_fresh._native.native_decide.ax_1_1,
+ treeListNil_fresh._native.native_decide.ax_1_1,
+ treeListRec_fresh._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ treeNode_fresh._native.native_decide.ax_1_1,
+ treeRec_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2SortInvS
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2IotaRule_ext' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d2AllRules_rhs_nodup._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2IotaRule_ext
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2IotaRule_levelsLength' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d2AllRules_rhs_nodup._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2IotaRule_levelsLength
+
+/--
+info: 'Lean4Lean.SExpr.ParamsD2.d2SortInvSExact' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ d0Def_fresh._native.native_decide.ax_1_1,
+ d0Def_name_ne_natRec._native.native_decide.ax_1_1,
+ d0Def_name_ne_natSucc._native.native_decide.ax_1_1,
+ d0Def_name_ne_natZero._native.native_decide.ax_1_1,
+ natClassify_d0Def_none._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d0Def._native.native_decide.ax_1_3,
+ probeNatGeneratedRuleSucc_lookup._native.native_decide.ax_1_1,
+ probeNatGeneratedRuleZero_lookup._native.native_decide.ax_1_1,
+ probeNatRecTypeV_eq._native.native_decide.ax_1_1,
+ probeNatRuleRhs_ne._native.native_decide.ax_1_1,
+ probeNatSuccCtorName._native.native_decide.ax_1_1,
+ probeNatSuccCtorTypeV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatSuccRuleRecName._native.native_decide.ax_1_1,
+ probeNatSuccRuleTypeV_eq._native.native_decide.ax_1_1,
+ probeNatTypeTypeV_eq._native.native_decide.ax_1_1,
+ probeNatZeroCtorName._native.native_decide.ax_1_1,
+ probeNatZeroRuleLhsV_eq._native.native_decide.ax_1_1,
+ probeNatZeroRuleRecName._native.native_decide.ax_1_1,
+ probeNatZeroRuleTypeV_eq._native.native_decide.ax_1_1,
+ d0Classify_d1MutA_none._native.native_decide.ax_1_1,
+ d0Classify_d1MutB_none._native.native_decide.ax_1_1,
+ d1MutA_fresh._native.native_decide.ax_1_1,
+ d1MutA_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutA_name_ne_mutB._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutA_name_ne_natZero._native.native_decide.ax_1_1,
+ d1MutB_fresh._native.native_decide.ax_1_1,
+ d1MutB_name_ne_d0Def._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natRec._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natSucc._native.native_decide.ax_1_1,
+ d1MutB_name_ne_natZero._native.native_decide.ax_1_1,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutA._native.native_decide.ax_1_3,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_2,
+ natRule_rhs_ne_d1MutB._native.native_decide.ax_1_3,
+ d1Classify_tree._native.native_decide.ax_1_1,
+ d1Classify_treeBranch._native.native_decide.ax_1_1,
+ d1Classify_treeLeaf._native.native_decide.ax_1_1,
+ d1Classify_treeList._native.native_decide.ax_1_1,
+ d1Classify_treeListCons._native.native_decide.ax_1_1,
+ d1Classify_treeListNil._native.native_decide.ax_1_1,
+ d1Classify_treeListRec._native.native_decide.ax_1_1,
+ d1Classify_treeNode._native.native_decide.ax_1_1,
+ d1Classify_treeRec._native.native_decide.ax_1_1,
+ d2AllRules_rhs_nodup._native.native_decide.ax_1_1,
+ d2Env_isSome._native.native_decide.ax_1_1,
+ treeBranch_fresh._native.native_decide.ax_1_1,
+ treeLeaf_fresh._native.native_decide.ax_1_1,
+ treeListCons_fresh._native.native_decide.ax_1_1,
+ treeListNil_fresh._native.native_decide.ax_1_1,
+ treeListRec_fresh._native.native_decide.ax_1_1,
+ treeList_fresh._native.native_decide.ax_1_1,
+ treeNode_fresh._native.native_decide.ax_1_1,
+ treeRec_fresh._native.native_decide.ax_1_1,
+ tree_fresh._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms d2SortInvSExact
+
+end ParamsD2
+end SExpr
+end Lean4Lean
diff --git a/Lean4Lean/Experimental/SExprTransport.lean b/Lean4Lean/Experimental/SExprTransport.lean
new file mode 100644
index 00000000..78b7ad6e
--- /dev/null
+++ b/Lean4Lean/Experimental/SExprTransport.lean
@@ -0,0 +1,360 @@
+import Lean4Lean.Experimental.SExpr
+
+/-!
+# L4L-16 R1: generic syntax transport between `Params` instances
+
+`SExpr` retains its complete `Params` value as an inductive parameter, so a
+declaration-history induction cannot keep one syntax type across rungs.  D0
+and D1 each hand-roll a four-way transport functor
+(`natToD0Expr`/`d0ToNatExpr`, `d0ToD1Expr`/`d1ToD0Expr`) together with its
+roundtrip and commutation lemmas — about 1200 lines of per-rung boilerplate.
+Everything in that layer depends only on the two instances agreeing on
+`univs`, so it is provable once, generically.  This module is that generic
+layer, promoted from the banked probe
+(`plans/probes/probeG-generic-instance.lean` §G1).
+
+Contents: `transportLevel`/`transportExpr` (the functor), the constructor
+congruence simp set, both roundtrips, level-operator commutation
+(`succ`/`imax`/`instV`), substitution transport (`lift'`, `subst`, `inst`,
+`mkInst`), pattern payload commutation (`applyS`, `defeqsS`), syntactic
+match transport (`MatchesS`), context lookup transport, and the
+context/level-list roundtrips.
+
+Deliberately *not* here: judgment transport (`IsDefEq`, `IsDefEqStrong`,
+`Pattern.Action`).  Those consume per-rung facts — environment inclusion,
+`Pat` inclusion, classifier agreement — and stay with the rung that owns
+them (`d0StrongToD1`, `d1StrongToD2`, …).  Refactoring D0/D1 onto this
+module is a recorded follow-up; this module is additive.
+-/
+
+namespace Lean4Lean
+namespace SExpr
+
+variable {P₀ P₁ : Params}
+
+/-! ## The transport functor -/
+
+/-- Level transport between any two instances agreeing on `univs`.  The
+carrier of `SLevel` is `Params`-independent; only the well-formedness
+witness moves. -/
+def transportLevel (h : @Params.univs P₀ = @Params.univs P₁)
+    (l : @SLevel P₀) : @SLevel P₁ :=
+  ⟨l.1, by
+    obtain ⟨u, hu, heval⟩ := l.2
+    exact ⟨u, h ▸ hu, heval⟩⟩
+
+/-- Expression transport, by the `SExpr` recursor. -/
+noncomputable def transportExpr (h : @Params.univs P₀ = @Params.univs P₁)
+    (e : @SExpr P₀) : @SExpr P₁ :=
+  @SExpr.rec P₀ (motive := fun _ => @SExpr P₁)
+    (fun i => @SExpr.bvar P₁ i)
+    (fun u => @SExpr.sort P₁ (transportLevel h u))
+    (fun c ls => @SExpr.const P₁ c (ls.map (transportLevel h)))
+    (fun _ _ f a => @SExpr.app P₁ f a)
+    (fun _ _ A body => @SExpr.lam P₁ A body)
+    (fun _ _ A B => @SExpr.forallE P₁ A B)
+    e
+
+/-! ## Roundtrips -/
+
+@[simp] theorem transportLevel_transportLevel
+    (h : @Params.univs P₀ = @Params.univs P₁) (l : @SLevel P₀) :
+    transportLevel h.symm (transportLevel h l) = l := by
+  apply Subtype.ext
+  rfl
+
+/-! ## Constructor congruences
+
+One parametric direction; the reverse direction is the same lemma at
+`h.symm`, so this six-lemma set replaces each rung's twelve. -/
+
+@[simp] theorem transportExpr_bvar (h : @Params.univs P₀ = @Params.univs P₁)
+    (i : Nat) :
+    transportExpr h (@SExpr.bvar P₀ i) = @SExpr.bvar P₁ i := rfl
+
+@[simp] theorem transportExpr_sort (h : @Params.univs P₀ = @Params.univs P₁)
+    (u : @SLevel P₀) :
+    transportExpr h (@SExpr.sort P₀ u) =
+      @SExpr.sort P₁ (transportLevel h u) := rfl
+
+@[simp] theorem transportExpr_const (h : @Params.univs P₀ = @Params.univs P₁)
+    (c : Name) (ls : List (@SLevel P₀)) :
+    transportExpr h (@SExpr.const P₀ c ls) =
+      @SExpr.const P₁ c (ls.map (transportLevel h)) := rfl
+
+@[simp] theorem transportExpr_app (h : @Params.univs P₀ = @Params.univs P₁)
+    (f a : @SExpr P₀) :
+    transportExpr h (@SExpr.app P₀ f a) =
+      @SExpr.app P₁ (transportExpr h f) (transportExpr h a) := rfl
+
+@[simp] theorem transportExpr_lam (h : @Params.univs P₀ = @Params.univs P₁)
+    (A e : @SExpr P₀) :
+    transportExpr h (@SExpr.lam P₀ A e) =
+      @SExpr.lam P₁ (transportExpr h A) (transportExpr h e) := rfl
+
+@[simp] theorem transportExpr_forallE
+    (h : @Params.univs P₀ = @Params.univs P₁) (A B : @SExpr P₀) :
+    transportExpr h (@SExpr.forallE P₀ A B) =
+      @SExpr.forallE P₁ (transportExpr h A) (transportExpr h B) := rfl
+
+@[simp] theorem transportExpr_transportExpr
+    (h : @Params.univs P₀ = @Params.univs P₁) (e : @SExpr P₀) :
+    transportExpr h.symm (transportExpr h e) = e := by
+  induction e <;> simp [List.map_map, Function.comp_def, *]
+
+/-! ## Level-operator commutation -/
+
+@[simp] theorem transportLevel_zero (h : @Params.univs P₀ = @Params.univs P₁) :
+    transportLevel h (@SLevel.zero P₀) = @SLevel.zero P₁ := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem transportLevel_succ (h : @Params.univs P₀ = @Params.univs P₁)
+    (u : @SLevel P₀) :
+    transportLevel h (@SLevel.succ P₀ u) =
+      @SLevel.succ P₁ (transportLevel h u) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem transportLevel_imax (h : @Params.univs P₀ = @Params.univs P₁)
+    (u v : @SLevel P₀) :
+    transportLevel h (@SLevel.imax P₀ u v) =
+      @SLevel.imax P₁ (transportLevel h u) (transportLevel h v) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem transportLevel_max (h : @Params.univs P₀ = @Params.univs P₁)
+    (u v : @SLevel P₀) :
+    transportLevel h (@SLevel.max P₀ u v) =
+      @SLevel.max P₁ (transportLevel h u) (transportLevel h v) := by
+  apply Subtype.ext
+  rfl
+
+@[simp] theorem transportLevel_instV (h : @Params.univs P₀ = @Params.univs P₁)
+    (ls : List (@SLevel P₀)) (u : VLevel) :
+    transportLevel h (@SLevel.instV P₀ ls u) =
+      @SLevel.instV P₁ (ls.map (transportLevel h)) u := by
+  apply Subtype.ext
+  funext v
+  change u.eval (ls.map fun l => l.1 v) =
+    u.eval ((ls.map (transportLevel h)).map fun l => l.1 v)
+  congr 1
+  simp [List.map_map, Function.comp_def, transportLevel]
+
+/-! ## Substitution transport -/
+
+/-- Substitution transport, pointwise. -/
+noncomputable def transportSubst (h : @Params.univs P₀ = @Params.univs P₁)
+    (σ : @Subst P₀) : @Subst P₁ := fun i => transportExpr h (σ i)
+
+@[simp] theorem transportExpr_lift' (h : @Params.univs P₀ = @Params.univs P₁)
+    (e : @SExpr P₀) (ρ : Lift) :
+    transportExpr h (@SExpr.lift' P₀ e ρ) =
+      @SExpr.lift' P₁ (transportExpr h e) ρ := by
+  induction e generalizing ρ <;> simp [SExpr.lift', *]
+
+@[simp] theorem transportSubst_lift (h : @Params.univs P₀ = @Params.univs P₁)
+    (σ : @Subst P₀) :
+    transportSubst h (@Subst.lift P₀ σ) =
+      @Subst.lift P₁ (transportSubst h σ) := by
+  funext i
+  cases i <;> simp [transportSubst, Subst.lift, transportExpr_lift']
+
+@[simp] theorem transportExpr_subst (h : @Params.univs P₀ = @Params.univs P₁)
+    (e : @SExpr P₀) (σ : @Subst P₀) :
+    transportExpr h (@SExpr.subst P₀ e σ) =
+      @SExpr.subst P₁ (transportExpr h e) (transportSubst h σ) := by
+  induction e generalizing σ <;> simp [SExpr.subst, transportSubst, *]
+
+@[simp] theorem transportExpr_inst (h : @Params.univs P₀ = @Params.univs P₁)
+    (e a : @SExpr P₀) :
+    transportExpr h (@SExpr.inst P₀ e a) =
+      @SExpr.inst P₁ (transportExpr h e) (transportExpr h a) := by
+  change transportExpr h
+      (@SExpr.subst P₀ e (@Subst.one P₀ a)) =
+    @SExpr.subst P₁ (transportExpr h e)
+      (@Subst.one P₁ (transportExpr h a))
+  rw [transportExpr_subst]
+  congr 1
+  funext i
+  cases i <;> rfl
+
+@[simp] theorem transportExpr_mkInst (h : @Params.univs P₀ = @Params.univs P₁)
+    (ls : List (@SLevel P₀)) (e : VExpr) :
+    transportExpr h (@SExpr.mkInst P₀ ls e) =
+      @SExpr.mkInst P₁ (ls.map (transportLevel h)) e := by
+  induction e <;> simp [SExpr.mkInst, List.map_map, Function.comp_def, *]
+
+/-! ## Iterated binder/application towers -/
+
+theorem transportExpr_foldr_forallE (h : @Params.univs P₀ = @Params.univs P₁)
+    (Ts : List (@SExpr P₀)) (e : @SExpr P₀) :
+    transportExpr h (Ts.foldr (fun A B => @SExpr.forallE P₀ A B) e) =
+      (Ts.map (transportExpr h)).foldr
+        (fun A B => @SExpr.forallE P₁ A B) (transportExpr h e) := by
+  induction Ts <;> simp [*]
+
+theorem transportExpr_foldr_app (h : @Params.univs P₀ = @Params.univs P₁)
+    (args : List (@SExpr P₀)) (e : @SExpr P₀) :
+    transportExpr h (args.foldr (fun A acc => @SExpr.app P₀ acc A) e) =
+      (args.map (transportExpr h)).foldr
+        (fun A acc => @SExpr.app P₁ acc A) (transportExpr h e) := by
+  induction args <;> simp [*]
+
+theorem transportExpr_foldl_app (h : @Params.univs P₀ = @Params.univs P₁)
+    (args : List (@SExpr P₀)) (e : @SExpr P₀) :
+    transportExpr h (args.foldl (fun acc A => @SExpr.app P₀ acc A) e) =
+      (args.map (transportExpr h)).foldl
+        (fun acc A => @SExpr.app P₁ acc A) (transportExpr h e) := by
+  induction args generalizing e <;> simp [*]
+
+/-! ## Pattern payload commutation
+
+`Pattern.RHS`/`Pattern.Check` are `Params`-independent (`.fixed` carries a
+`VExpr`), so payloads need no transport at all; only their `applyS`
+computation commutes with the functor. -/
+
+@[simp] theorem transportExpr_rhs_applyS
+    (h : @Params.univs P₀ = @Params.univs P₁) {p : Pattern}
+    (r : p.RHS) (m₁ : List (@SLevel P₀)) (m₂ : p.Path → @SExpr P₀) :
+    transportExpr h (@Pattern.RHS.applyS P₀ p m₁ m₂ r) =
+      @Pattern.RHS.applyS P₁ p (m₁.map (transportLevel h))
+        (fun path => transportExpr h (m₂ path)) r := by
+  induction r with
+  | fixed e closed => exact transportExpr_mkInst h m₁ e
+  | var path => rfl
+  | app f a ihf iha =>
+    simp only [Pattern.RHS.applyS, transportExpr_app, ihf, iha]
+
+theorem transport_defeqsS (h : @Params.univs P₀ = @Params.univs P₁)
+    {p : Pattern} (ck : p.Check) (m₁ : List (@SLevel P₀))
+    (m₂ : p.Path → @SExpr P₀) :
+    (@Pattern.Check.defeqsS P₀ p m₁ m₂ ck).map
+        (fun ab => (transportExpr h ab.1, transportExpr h ab.2)) =
+      @Pattern.Check.defeqsS P₁ p (m₁.map (transportLevel h))
+        (fun path => transportExpr h (m₂ path)) ck := by
+  induction ck with
+  | true => rfl
+  | defeq a b rest ih =>
+    simp only [Pattern.Check.defeqsS, List.map_cons, ih,
+      transportExpr_rhs_applyS]
+
+/-- Transport a triple list of local check evidence. -/
+noncomputable def transportDfs (h : @Params.univs P₀ = @Params.univs P₁)
+    (dfs : List (@SExpr P₀ × @SExpr P₀ × @SExpr P₀)) :
+    List (@SExpr P₁ × @SExpr P₁ × @SExpr P₁) :=
+  dfs.map fun (B, a, b) =>
+    (transportExpr h B, transportExpr h a, transportExpr h b)
+
+theorem transportDfs_map_snd (h : @Params.univs P₀ = @Params.univs P₁)
+    (dfs : List (@SExpr P₀ × @SExpr P₀ × @SExpr P₀)) :
+    (transportDfs h dfs).map (fun x => x.2) =
+      (dfs.map fun x => x.2).map fun ab =>
+        (transportExpr h ab.1, transportExpr h ab.2) := by
+  simp [transportDfs, List.map_map, Function.comp_def]
+
+/-! ## Syntactic match transport -/
+
+theorem transportMatchesS (h : @Params.univs P₀ = @Params.univs P₁)
+    {p : Pattern} {e : @SExpr P₀} {m₁ : List (@SLevel P₀)}
+    {m₂ : p.Path → @SExpr P₀}
+    (H : @Pattern.MatchesS P₀ p e m₁ m₂) :
+    @Pattern.MatchesS P₁ p (transportExpr h e)
+      (m₁.map (transportLevel h))
+      (fun path => transportExpr h (m₂ path)) := by
+  induction H with
+  | @const c ls =>
+    rw [transportExpr_const]
+    refine cast ?_ (@Pattern.MatchesS.const P₁ c (ls.map (transportLevel h)))
+    congr 1
+    funext path
+    exact Empty.elim path
+  | @var f f' f₁ g₁ a' _ ih =>
+    change @Pattern.MatchesS P₁ (.var f)
+      (.app (transportExpr h f') (transportExpr h a'))
+      (f₁.map (transportLevel h))
+      (fun path => transportExpr h (Option.elim path a' g₁))
+    have heq : (fun path => transportExpr h (Option.elim path a' g₁)) =
+        (fun path => Option.elim path (transportExpr h a')
+          (fun path => transportExpr h (g₁ path))) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ih.var
+  | @app f f' f₁ g₁ a a' f₂ g₂ _ _ ihf iha =>
+    change @Pattern.MatchesS P₁ (.app f a)
+      (@SExpr.app P₁ (transportExpr h f') (transportExpr h a'))
+      (f₁.map (transportLevel h))
+      (fun path => transportExpr h (Sum.elim g₁ g₂ path))
+    have heq : (fun path => transportExpr h (Sum.elim g₁ g₂ path)) =
+        Sum.elim (fun path => transportExpr h (g₁ path))
+          (fun path => transportExpr h (g₂ path)) := by
+      funext path
+      cases path <;> rfl
+    rw [heq]
+    exact ihf.app iha
+
+/-! ## Context lookup transport -/
+
+theorem transportLookup (h : @Params.univs P₀ = @Params.univs P₁)
+    {Γ : List (@SExpr P₀)} {i : Nat} {A : @SExpr P₀}
+    (H : @Lookup P₀ Γ i A) :
+    @Lookup P₁ (Γ.map (transportExpr h)) i (transportExpr h A) := by
+  induction H with
+  | zero =>
+    rw [transportExpr_lift']
+    exact .zero
+  | succ _ ih =>
+    rw [transportExpr_lift']
+    exact .succ ih
+
+/-! ## List roundtrips -/
+
+@[simp] theorem transport_context_roundtrip
+    (h : @Params.univs P₀ = @Params.univs P₁) (Γ : List (@SExpr P₁)) :
+    (Γ.map (transportExpr h.symm)).map (transportExpr h) = Γ := by
+  rw [List.map_map]
+  refine List.map_id''' Γ fun e _ => ?_
+  show transportExpr h (transportExpr h.symm e) = e
+  simp [transportExpr_transportExpr h.symm e]
+
+@[simp] theorem transport_level_list_roundtrip
+    (h : @Params.univs P₀ = @Params.univs P₁) (ls : List (@SLevel P₁)) :
+    (ls.map (transportLevel h.symm)).map (transportLevel h) = ls := by
+  rw [List.map_map]
+  refine List.map_id''' ls fun l _ => ?_
+  show transportLevel h (transportLevel h.symm l) = l
+  simp [transportLevel_transportLevel h.symm l]
+
+
+/-! ## Axiom closures
+
+The whole transport layer is proof-complete: it is pure syntax, so it
+carries neither `Classical.choice` (the functor is defined by the `SExpr`
+recursor, not chosen) nor any admission. -/
+
+/-- info: 'Lean4Lean.SExpr.transportLevel' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transportLevel
+
+/-- info: 'Lean4Lean.SExpr.transportExpr' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transportExpr
+
+/-- info: 'Lean4Lean.SExpr.transportExpr_transportExpr' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transportExpr_transportExpr
+
+/-- info: 'Lean4Lean.SExpr.transportExpr_mkInst' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transportExpr_mkInst
+
+/-- info: 'Lean4Lean.SExpr.transportMatchesS' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transportMatchesS
+
+/-- info: 'Lean4Lean.SExpr.transport_context_roundtrip' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms transport_context_roundtrip
+end SExpr
+end Lean4Lean
diff --git a/Lean4Lean/Experimental/ShapeLogRel.lean b/Lean4Lean/Experimental/ShapeLogRel.lean
index ac55969e..85b2e5f8 100644
--- a/Lean4Lean/Experimental/ShapeLogRel.lean
+++ b/Lean4Lean/Experimental/ShapeLogRel.lean
@@ -1,5 +1,14 @@
 import Lean4Lean.Experimental.SExpr
 
+/-
+`Shape.plift` and friends below are written in `Option`-monad `do`/`return` notation, and
+the proofs about them `simp` through the exact term that notation elaborates to.
+leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, which reshapes
+those terms. Pin the legacy elaborator here until the proofs are migrated
+(digama0/lean4lean#31).
+-/
+set_option backward.do.legacy true
+
 namespace Lean4Lean
 open Lean4Lean
 
@@ -22,12 +31,12 @@ private noncomputable instance : DecidableEq SLevel := fun a b => Classical.prop
     simp [SLevel.imax, SLevel.zero] at hv
     apply Subtype.ext; funext v
     have := congrFun hv v
-    simp [Nat.imax, VLevel.eval] at this
+    simp [Lean.Nat.imax, VLevel.eval] at this
     exact Decidable.byContradiction fun h => absurd (this h).2 h
   · intro h
     subst h
     apply Subtype.ext; funext v
-    simp [SLevel.imax, SLevel.zero, Nat.imax, VLevel.eval]
+    simp [SLevel.imax, SLevel.zero, Lean.Nat.imax, VLevel.eval]
 
 inductive Shape0 : Type where
   | bot : Shape0
@@ -41,7 +50,7 @@ inductive ShapeS (Shape : Type) : Type where
   | ctor : Name → List Shape → ShapeS Shape
   | indTy : ShapeS Shape
 
-def Shape : Nat → Type
+@[implicit_reducible] def Shape : Nat → Type
   | 0 => Shape0
   | n + 1 => ShapeS (Shape n)
 
@@ -916,8 +925,8 @@ protected theorem Shape.WF.sort : (Shape.sort (n := n) r).WF := by cases n <;> t
 protected theorem ShapeFun.WF.bot : (ShapeFun.bot (n := n)).WF Shape.WF := by
   simp [WF, bot, Shape.Compat.bot_l, Shape.bot_join, Shape.WF.bot]
 
-def WShape (n : Nat) := {s : Shape n // s.WF}
-def WShapeFun (n : Nat) := {s : ShapeFun n // s.WF Shape.WF}
+@[implicit_reducible] def WShape (n : Nat) := {s : Shape n // s.WF}
+@[implicit_reducible] def WShapeFun (n : Nat) := {s : ShapeFun n // s.WF Shape.WF}
 
 instance : Membership (WShape n × WShape n) (WShapeFun n) := ⟨fun f a => (a.1.1, a.2.1) ∈ f.1⟩
 
@@ -1171,6 +1180,28 @@ theorem WShapeFun.LE.def' {f f' : WShapeFun n} : f ≤ f' ↔
 theorem WShape.lift_mono {s t : WShape n} (le : n ≤ m) : s ≤ t → s.lift m ≤ t.lift m :=
   (lift_le_lift le).2
 
+/-- Lift both sides of a pointwise list bound through a second common
+shape level.  This is the list-level transport used when a constant's
+semantic function depth and its accumulated application-spine depth differ. -/
+theorem WShape.forall₂_lift
+    {xs : List (WShape n)} {ys : List (WShape n')}
+    (hn : n ≤ n') (hnk : n' ≤ k)
+    (H : List.Forall₂ (· ≤ ·) (xs.map (fun x => x.lift n')) ys) :
+    List.Forall₂ (· ≤ ·) (xs.map (fun x => x.lift k))
+      (ys.map (fun y => y.lift k)) := by
+  induction xs generalizing ys with
+  | nil =>
+    simp only [List.map_nil] at H ⊢
+    cases H
+    exact .nil
+  | cons x xs ih =>
+    simp only [List.map_cons] at H ⊢
+    cases H with
+    | cons hxy hrest =>
+      refine .cons ?_ (ih hrest)
+      have h := WShape.lift_mono hnk hxy
+      rwa [WShape.lift_lift (.inl hn)] at h
+
 theorem WShape.lift_le_bot {s : WShape n} (h : n ≤ m) : s.lift m ≤ .bot ↔ s = .bot := by
   rw [← WShape.lift_bot (n := n), WShape.lift_le_lift h]
   exact ⟨fun h => WShape.ext (Shape.le_bot.1 h), fun h => h ▸ Shape.LE.rfl⟩
@@ -1509,7 +1540,8 @@ theorem ih_fun {f f' : WShapeFun n} :
     have ⟨_, g1, g2, dg⟩ := app_core ih f' d; have ⟨g3, g4, g2⟩ := f'.mem_val' g2
     have ⟨e, e1, e2⟩ := of_compat ih (x := ⟨_, f4⟩) (x' := ⟨_, g4⟩) (compat_app_l ih hc d)
     refine d1 ▸ e1 ▸ ⟨d.2, e.2⟩
-  · intro f₃; conv => enter [1,x,y,1]; simp only [WShapeFun.mem_def, ShapeFun.mem_join]
+  · intro f₃; conv =>
+      enter [1,x,y,1]; (conv => apply propext WShapeFun.mem_def); simp only [ShapeFun.mem_join]
     refine ⟨fun H => ?_, fun ⟨H1, H2⟩ => ?_⟩
     · refine ⟨fun x y hf => ?_, fun x y hf' => ?_⟩
       · have ⟨_, hf'⟩ := f'.bot_mem
@@ -1652,74 +1684,13 @@ theorem WShapeFun.join_mem {f : WShapeFun n}
     join (.sort r : WShape n) (.sort r') = if r = r' then .sort r else .bot := by
   ext1; simp [join, WShape.Compat, sort, Shape.Compat.sort_sort]; split <;> rfl
 
-/-
-protected theorem Shape.WF.plift (x : WShape n) :
-    WF (n := m) x.1.plift.1 ∧ ∀ y : Shape m, x.1.plift.2 = some y → y.WF := by
-  induction m generalizing n with | zero => exact ⟨trivial, fun _ _ => trivial⟩ | succ m ih
-  cases n with | zero => obtain ⟨⟨⟩⟩ := x <;> simp [WF, plift] | succ n
-  specialize @ih n
-  let rec go (x : WShapeFun n) :
-      ShapeFun.WF (n := m) WF (ShapeFun.plift plift x.1).1 ∧
-      ∀ y : ShapeFun m, (ShapeFun.plift plift x.1).2 = some y → ShapeFun.WF WF y := by
-    obtain le | le := Nat.le_total n m
-    · simp [ShapeFun.plift_eq_lift le, ShapeFun.WF.lift le x.2]
-    simp [ShapeFun.plift, ShapeFun.WF, ShapeFun.WF', List.mapM_eq_some]
-    -- have ⟨⟨⟨_, a1⟩, a2⟩, a3⟩ := x.2
-    refine ⟨⟨⟨?_, ?_⟩, ?_⟩, fun _ h1 => ⟨⟨?_, ?_⟩, fun _ _ h2 => ?_⟩⟩
-    · have ⟨_, h⟩ := x.2.1.1; exact ⟨_, _, _, h, _, by cases n <;> rfl, rfl, rfl⟩
-    · intro _ _ _ _ h1 b₂ h2 rfl rfl _ _ _ _ h3 c₂ h4 rfl rfl; refine ⟨fun h => ?_, fun h => ?_⟩
-      · replace ⟨b1, _, h1⟩ := x.mem_val' h1; replace ⟨c1, _, h3⟩ := x.mem_val' h3
-        refine have hc := by exact Compat.plift.2 h2 h4 h
-          have ⟨⟨d, d'⟩, d1, d2, d3⟩ := x.join_mem h1 h3 hc; ?_
-        let b₂' : WShape _ := ⟨b₂, (ih ⟨_, b1⟩).2 _ h2⟩
-        let c₂' : WShape _ := ⟨c₂, (ih ⟨_, c1⟩).2 _ h4⟩
-        change b₂'.Compat c₂' at h
-        have jeq : (b₂'.join c₂').1 = b₂.join c₂ := by simp [b₂', c₂', WShape.join_val h]
-        have ⟨j1, j2⟩ := (WShape.Join.mk h).le
-        simp [WShape.LE.def, b₂', c₂', jeq] at j1 j2
-        have : d.1 ≤ ((b₂'.join c₂').lift n).1 := by
-          refine d3.trans <| (WShape.Join.mk hc _).2 ⟨?_, ?_⟩ <;>
-            simp [WShape.LE.def, WShape.lift_val le, jeq, ← plift_le le] <;> exact ⟨_, ‹_›, ‹_›⟩
-        have ⟨d₂, e1, e2⟩ := (plift_le le).2 (jeq ▸ WShape.lift_val le ▸ this :)
-        refine ⟨_, ⟨_, _, _, d1, _, e1, rfl, rfl⟩, jeq ▸ (?_ : _ ≤ d₂), e2⟩
-        have ⟨j3, j4⟩ := (WShape.Join.mk hc _).1 d2
-        have := (plift_le le).1 ⟨_, e1, .rfl⟩
-        refine (WShape.Join.mk h ⟨d₂, (ih _).2 _ e1⟩).2 ⟨?_, ?_⟩
-        · have ⟨_, f1, f2⟩ := (plift_le le).2 (j3.trans this); cases h2.symm.trans f1; exact f2
-        · have ⟨_, f1, f2⟩ := (plift_le le).2 (j4.trans this); cases h4.symm.trans f1; exact f2
-      · rename_i b b' c c'
-        refine plift_mono <| x.mem_mono (x.mem_val h1) (x.mem_val h3) ?_
-        sorry
-    stop
-    · intro _ _ _ _ h1 _ h2 rfl rfl; exact ⟨(ih (a3 _ h1).1).2 _ h2, (ih (a3 _ h1).2).1⟩
-    · have ⟨_, b1, _, _, rfl⟩ := h1.forall_exists_l _ a1; exact ⟨_, by simpa using b1⟩
-    · intro _ b₂ h2 _ c₂ h3
-      obtain ⟨⟨b, b'⟩, b1, _, b2, ⟨⟩⟩ := h1.forall_exists_r _ h2
-      obtain ⟨⟨c, c'⟩, c1, _, c2, ⟨⟩⟩ := h1.forall_exists_r _ h3; dsimp at *
-      refine ⟨fun h => ?_, fun h => ?_⟩
-      · sorry
-      · sorry
-    · obtain ⟨⟨b, b'⟩, b1, _, b2, ⟨⟩⟩ := h1.forall_exists_r _ h2
-      exact ⟨(ih (a3 _ b1).1).1, (ih (a3 _ b1).2).2 _ b2⟩
-  obtain ⟨x, wf⟩ := x
-  cases x with simp [WF] at wf <;> simp [plift, WF, List.mapM_eq_some, *]
-  | forallE =>
-    refine ⟨⟨(ih ⟨_, wf.1⟩).1, (go ⟨_, wf.2⟩).1⟩, ?_⟩
-    rintro _ _ h1 _ h2 rfl; exact ⟨(ih ⟨_, wf.1⟩).2 _ h1, (go ⟨_, wf.2⟩).2 _ h2⟩
-  | lam => exact ⟨⟨(go ⟨_, wf.1⟩).1, sorry⟩, fun _ h1 => ⟨(go ⟨_, wf.1⟩).2 _ h1, sorry⟩⟩
-  | ctor =>
-    refine ⟨⟨fun _ h1 => (ih ⟨_, wf.1 _ h1⟩).1, sorry⟩, fun _ h1 => ⟨fun _ h2 => ?_, sorry⟩⟩
-    have ⟨_, h3, h4⟩ := h1.forall_exists_r _ h2; exact (ih ⟨_, wf.1 _ h3⟩).2 _ h4
-
--- theorem ShapeFun.WF'.plift (h : WF (n := n) Shape.WF x) :
---     WF (n := m) Shape.WF (plift Shape.plift x).1 ∧
---     ∀ y : ShapeFun m, (plift Shape.plift x).2 = some y → WF Shape.WF y := by
---   sorry
-
--- theorem Shape.WF.plift (h : WF (n := n) x) : WF (n := m) x.plift.1 := sorry
--- theorem ShapeFun.WF.plift (h : WF (n := n) Shape.WF x) :
---     WF (n := m) Shape.WF (plift Shape.plift x).1 := sorry
--/
+/- The general `Shape.WF.plift` well-formedness-projection principle
+(pushing a well-formed higher-level shape down to an arbitrary lower
+level) was rejected and its prototype deleted: downward projection can
+destroy the `NonZero`/join-closure invariants at `lam`/`ctor` nodes. The
+order-theoretic `plift` lemmas above are the surviving true fragment;
+transport of refinement evidence is instead carried as data by
+`LRS.CtorDefEq.lift`/`.unlift` and `LogRel.LiftEquiv` below. -/
 
 theorem WShape.Join.lift {x y z : WShape n} (le : n ≤ m) :
     (x.lift m).Join (y.lift m) (z.lift m) ↔ x.Join y z := by
@@ -1806,7 +1777,7 @@ theorem WShapeFun.mem_ofElems {f : List (WShape n × WShape n)} {h1 h2} :
   exact ⟨fun ⟨⟨a, b⟩, h, ha, hb⟩ => by cases WShape.ext ha; cases WShape.ext hb; exact h,
     fun h => ⟨_, h, rfl, rfl⟩⟩
 
-def TShape := Σ n, WShape n
+@[implicit_reducible] def TShape := Σ n, WShape n
 abbrev WShape.T : WShape n → TShape := Sigma.mk _
 
 def TShape.LE (a b : TShape) : Prop := a.2.lift (max a.1 b.1) ≤ b.2.lift _
@@ -1950,6 +1921,18 @@ theorem TShape.indTy_not_le_lam' {f : WShapeFun n'} :
     WShape.lift_lam' (Nat.le_max_right ..), WShape.indTy_le]
   unfold WShape.lam'; split <;> rintro ⟨⟩
 
+theorem TShape.indTy_not_le_ctor' {c : Name} {l : List (WShape n')} :
+    ¬(WShape.indTy : WShape (n+1)).T ≤ (WShape.ctor' c l).T := by
+  intro h
+  rw [TShape.LE.def (m := max n n' + 1)
+      (Nat.succ_le_succ (Nat.le_max_left ..))
+      (Nat.succ_le_succ (Nat.le_max_right ..)),
+    WShape.lift_indTy (n := n) (m := max n n'),
+    WShape.lift_ctor' (Nat.le_max_right ..), WShape.indTy_le] at h
+  unfold WShape.ctor' at h
+  split at h <;> simp_all [WShape.ext_iff, WShape.ctor, WShape.bot,
+    WShape.indTy, Shape.bot]
+
 theorem TShape.lam_not_le_forallE {f₁ : WShapeFun n} {hl} {a' : WShape n'} {f' : WShapeFun n'} :
     ¬(.lam f₁ hl : WShape (n+1)).T ≤ (.forallE a' f' : WShape (n'+1)).T := by
   have' le₁ := Nat.le_max_left ..; have' le₂ := Nat.le_max_right ..
@@ -2014,6 +1997,46 @@ theorem TShape.indTy_not_le_sort :
   rw [TShape.LE.def (Nat.le_refl _) (Nat.zero_le _), WShape.lift_self, WShape.indTy_le] at this
   cases this
 
+theorem TShape.sort_not_le_indTy :
+    ¬(.sort r : WShape n).T ≤ (WShape.indTy : WShape (n'+1)).T := by
+  intro h
+  have le₁ : n ≤ n + n' + 1 := by omega
+  have le₂ : n' + 1 ≤ n + n' + 1 := by omega
+  rw [TShape.LE.def (m := n + n' + 1) le₁ le₂, WShape.lift_sort,
+    WShape.lift_indTy (n := n') (m := n + n'), WShape.le_indTy] at h
+  simp [WShape.ext_iff, WShape.sort, WShape.bot, WShape.indTy,
+    Shape.sort, Shape.bot] at h
+
+theorem TShape.forallE_not_le_indTy {a : WShape n} {f : WShapeFun n} :
+    ¬(.forallE a f : WShape (n+1)).T ≤ (WShape.indTy : WShape (n'+1)).T := by
+  intro h
+  rw [TShape.LE.def (m := max n n' + 1)
+      (Nat.succ_le_succ (Nat.le_max_left ..))
+      (Nat.succ_le_succ (Nat.le_max_right ..)),
+    WShape.lift_forallE (Nat.le_max_left ..),
+    WShape.lift_indTy (n := n') (m := max n n'), WShape.le_indTy] at h
+  simp [WShape.ext_iff, WShape.forallE, WShape.bot, WShape.indTy, Shape.bot] at h
+
+theorem TShape.lam_not_le_indTy {f : WShapeFun n} {hl : f.NonZero} :
+    ¬(.lam f hl : WShape (n+1)).T ≤ (WShape.indTy : WShape (n'+1)).T := by
+  intro h
+  rw [TShape.LE.def (m := max n n' + 1)
+      (Nat.succ_le_succ (Nat.le_max_left ..))
+      (Nat.succ_le_succ (Nat.le_max_right ..)),
+    WShape.lift_lam (Nat.le_max_left ..),
+    WShape.lift_indTy (n := n') (m := max n n'), WShape.le_indTy] at h
+  simp [WShape.ext_iff, WShape.lam, WShape.bot, WShape.indTy, Shape.bot] at h
+
+theorem TShape.ctor_not_le_indTy {c : Name} {l : List (WShape n)} {wf} :
+    ¬(.ctor c l wf : WShape (n+1)).T ≤ (WShape.indTy : WShape (n'+1)).T := by
+  intro h
+  rw [TShape.LE.def (m := max n n' + 1)
+      (Nat.succ_le_succ (Nat.le_max_left ..))
+      (Nat.succ_le_succ (Nat.le_max_right ..)),
+    WShape.lift_ctor (Nat.le_max_left ..),
+    WShape.lift_indTy (n := n') (m := max n n'), WShape.le_indTy] at h
+  simp [WShape.ext_iff, WShape.ctor, WShape.bot, WShape.indTy, Shape.bot] at h
+
 theorem WShape.Compat_lift_val {a : WShape n₁} {b : WShape n₂}
     (le₁ : n₁ ≤ m) (le₂ : n₂ ≤ m) :
     (a.lift m).Compat (b.lift m) ↔ (a.1.lift m).Compat (b.1.lift m) := by
@@ -2187,6 +2210,27 @@ theorem WShape.ctor'_le_ctor' (h : List.Forall₂ (· ≤ ·) l l') :
   rw [dif_pos (WShape.ListNonZero.mono h ∘ h1)]
   exact Shape.LE.def.2 ⟨rfl, by simpa⟩
 
+theorem TShape.ctor_le_ctor'_nil
+    {c c' : Name} {l : List (WShape n)} {h} {n' : Nat}
+    (hcl : Params.classify c' = some (.ctor 0))
+    (hle : (WShape.ctor c l h : WShape (n+1)).T ≤
+      (WShape.ctor' c' ([] : List (WShape n'))).T) : c = c' ∧ l = [] := by
+  have le₁ := Nat.le_max_left n n'
+  have le₂ := Nat.le_max_right n n'
+  rw [TShape.LE.def (Nat.succ_le_succ le₁) (Nat.succ_le_succ le₂),
+    WShape.lift_ctor le₁, WShape.lift_ctor' le₂] at hle
+  unfold WShape.ctor' at hle
+  rw [dif_pos (by simpa [IsStruct, hcl])] at hle
+  rw [WShape.ctor_le] at hle
+  obtain ⟨l', h', heq, hargs⟩ := hle
+  have ⟨hc, hl'⟩ := WShape.ctor.inj.1 heq
+  cases hl'
+  have hnil : l = [] := by
+    cases l with
+    | nil => rfl
+    | cons => cases hargs
+  exact ⟨hc.symm, hnil⟩
+
 theorem TShape.ctor_not_le_forallE :
     ¬(WShape.ctor c l h : WShape (n+1)).T ≤ (.forallE a' f' : WShape (n'+1)).T := fun h => by
   rw [TShape.LE.def (Nat.succ_le_succ (Nat.le_max_left ..))
@@ -2934,6 +2978,22 @@ theorem WShape.HasType.forallE_l {a : WShape n} {f : WShapeFun n} :
   generalize a.1 = a₁, f.1 = f₁, t.1 = t₁
   refine ⟨fun (.forallE H) => ⟨_, H, rfl⟩, fun ⟨_, H, eq⟩ => eq ▸ .forallE H⟩
 
+theorem WShape.HasType.lam_l {f : WShapeFun n} {hf : f.NonZero}
+    {t : WShape (n + 1)} :
+    HasType (.lam f hf) t ↔
+      ∃ a b, HasTypeLam f a b ∧ t = .forallE a b := by
+  constructor
+  · intro H
+    obtain ⟨t, twf⟩ := t
+    change @Shape.HasType (n + 1) (ShapeS.lam f.1) t at H
+    cases Shape.HasType.unfold H with
+    | @lam _ _ _ _ hLam =>
+      exact ⟨⟨_, twf.1⟩, ⟨_, twf.2⟩, hLam, rfl⟩
+  · rintro ⟨a, b, H, rfl⟩
+    change @Shape.HasType (n + 1) (ShapeS.lam f.1)
+      (ShapeS.forallE a.1 b.1)
+    exact Shape.HasType.lam H
+
 theorem WShape.HasType.forallE_inv {m : WShape (n+1)} {a : WShape n} {f : WShapeFun n}
     (H : HasType m (.forallE a f)) : ∃ g, m = .lam' g ∧ HasTypeLam g a f := by
   generalize eq : a.forallE f = a' at H
@@ -3305,10 +3365,647 @@ variable {p : Pattern} (ls : List SLevel) (m2 : p.Path → TShape)
   (R : TShape → SExpr → Prop) in
 inductive LE_Interp.RHS : TShape → p.RHS → Prop
   | bot : RHS (WShape.T .bot) r
-  | const : R m ((SExpr.mk e).instL ls) → RHS m (.fixed e cl)
+  | const : R m (SExpr.mkInst ls e) → RHS m (.fixed e cl)
   | var : m ≤ m2 path → RHS m (.var path)
   | app : RHS (WShape.T (n := n + 1) f) F → RHS a.T A → m ≤ (f.app a).T → RHS m (.app F A)
 
+/-- The semantic application spine selected by an ordered list of capture
+paths.  Each step retains both the semantic argument bound attached to the
+path and the (possibly strict) result bound chosen by `RHS.app`. -/
+inductive LE_Interp.RHS.ShapeSpine {p : Pattern}
+    (m2 : p.Path → TShape) : TShape → List p.Path → TShape → Prop
+  | nil : ShapeSpine m2 head [] head
+  | cons {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+      {m out : TShape} {path : p.Path} {paths : List p.Path} :
+    a.T ≤ m2 path →
+    m ≤ (f.app a).T →
+    ShapeSpine m2 m paths out →
+    ShapeSpine m2 f.T (path :: paths) out
+
+/-- A semantic variable RHS is bounded by the shape assigned to its path,
+including the proof-irrelevant bottom interpretation. -/
+theorem LE_Interp.RHS.var_le
+    (H : LE_Interp.RHS ls m2 R m (.var path)) : m ≤ m2 path := by
+  cases H with
+  | bot => exact TShape.bot_le'
+  | var h => exact h
+
+/-- Once the head of a semantic application spine is bottom, every later
+application result is bottom as well. -/
+theorem LE_Interp.RHS.ShapeSpine.le_bot
+    (H : ShapeSpine m2 head paths out) (hhead : head ≤ TShape.bot) :
+    out ≤ TShape.bot := by
+  induction H with
+  | nil => exact hhead
+  | @cons n f a m out path paths harg happ hrest ih =>
+    have hf_bot : f = .bot := by
+      exact TShape.le_bot.1 hhead
+    have happ_bot : (f.app a).T ≤ TShape.bot := by
+      rw [hf_bot, WShape.bot_app]
+      exact TShape.bot_eqv.1
+    exact ih (happ.trans happ_bot)
+
+/-- Enlarge every capture bound without changing the ordered application
+spine.  This is used by proof-relevant RHS inversion when the same capture
+path occurs more than once: its selected argument observations are joined,
+while the fixed-head witness remains untouched. -/
+theorem LE_Interp.RHS.ShapeSpine.mono_l
+    (H : ShapeSpine m2 head paths out)
+    (hle : ∀ path, m2 path ≤ m2' path) :
+    ShapeSpine m2' head paths out := by
+  induction H with
+  | nil => exact .nil
+  | cons harg happ _ ih => exact .cons (harg.trans (hle _)) happ ih
+
+/-- Reassemble an `appN` RHS from its fixed head and ordered semantic
+application spine.  Keeping this direction separate from `appN_vars` lets a
+proof-relevant producer replace the ambient evaluator relation by the
+singleton relation generated by the exact fixed-head witness it selected. -/
+theorem LE_Interp.RHS.ShapeSpine.to_appN
+    (H : ShapeSpine m2 head paths out)
+    (hhead : LE_Interp.RHS ls m2 R head f) :
+    LE_Interp.RHS ls m2 R out
+      (Pattern.RHS.appN f (paths.map fun path => .var path)) := by
+  induction H generalizing f with
+  | nil => exact hhead
+  | cons harg happ _ ih =>
+    simp only [List.map_cons, Pattern.RHS.appN]
+    exact ih (.app hhead (.var harg) happ)
+
+/-- Reconstruct a typed lower approximation of the fixed head from a typed
+semantic RHS result.  Each application layer is represented by a singleton
+function shape: its input is the related capture approximation and its output
+is the typed approximation recursively recovered from the remaining spine.
+
+This is the shape-level half of the generated-iota logical telescope.  It is
+deliberately independent of syntax and of the logical relation; the adequacy
+consumer separately aligns the synthesized type telescope with the registered
+RHS type while following the well-founded semantic `R` edge. -/
+theorem LE_Interp.RHS.ShapeSpine.typedLowerHead
+    {p : Pattern} {m2 : p.Path → TShape} {paths : List p.Path}
+    {head out outTy : TShape}
+    (H : LE_Interp.RHS.ShapeSpine m2 head paths out)
+    (hcap : ∀ path, ∃ elem elemTy : TShape,
+      m2 path ≤ elem ∧ elem.HasType elemTy)
+    (hout : out.HasType outTy) :
+    ∃ elem elemTy : TShape, elem ≤ head ∧ elem.HasType elemTy := by
+  induction H generalizing outTy with
+  | @nil head0 => exact ⟨head0, outTy, .rfl, hout⟩
+  | @cons n f a m out path paths harg happ hrest ih =>
+    obtain ⟨next, nextTy, hnext, hnextTy⟩ := ih hout
+    by_cases hnextBot : next ≤ TShape.bot
+    · exact ⟨WShape.T (n := n + 1) .bot, WShape.T .type,
+        TShape.bot_le', WShape.HasType.T (.bot' .sort)⟩
+    obtain ⟨arg, argTy, harg', hargTy⟩ := hcap path
+    have hnextApp : next ≤ (f.app a).T := hnext.trans happ
+    cases f using WShape.casesOn' with
+    | bot => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | sort => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | forallE => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | ctor => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | indTy => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | @lam g hg =>
+      let k := max n (max (max arg.1 argTy.1) (max next.1 nextTy.1))
+      have hk : n ≤ k ∧ arg.1 ≤ k ∧ argTy.1 ≤ k ∧
+          next.1 ≤ k ∧ nextTy.1 ≤ k := by
+        dsimp [k]
+        omega
+      let argK : WShape k := arg.2.lift k
+      let argTyK : WShape k := argTy.2.lift k
+      let nextK : WShape k := next.2.lift k
+      let nextTyK : WShape k := nextTy.2.lift k
+      let elemFun : WShapeFun k := .single argK nextK
+      let typeFun : WShapeFun k := .single argK nextTyK
+      let elemHead : WShape (k + 1) := .lam' elemFun
+      let typeHead : WShape (k + 1) := .forallE argTyK typeFun
+      have hargKTy : argK.HasType argTyK :=
+        (TShape.HasType.def hk.2.1 hk.2.2.1).1 hargTy
+      have hnextKTy : nextK.HasType nextTyK :=
+        (TShape.HasType.def hk.2.2.2.1 hk.2.2.2.2).1 hnextTy
+      have helemTyped : elemHead.HasType typeHead := by
+        apply WShape.HasType.lam
+        refine WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+        · refine WShape.HasTypePi.def.2
+            ⟨WShape.HasDom.single.2 (.inl hargKTy), ?_⟩
+          intro x y hxy
+          obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ := WShapeFun.mem_single.1 hxy
+          · exact hnextKTy.isType
+          · exact .bot' .sort
+        · exact WShape.HasDom.single.2 (.inl hargKTy)
+        · simp only [elemFun, typeFun, WShapeFun.single_app]
+          split <;> [exact hnextKTy; exact .bot' (.bot' .sort)]
+      have hargBound : a.T ≤ arg := harg.trans harg'
+      have hnextAppK : nextK ≤ (g.lift k).app argK := by
+        have hnextApp' : next ≤ ((WShape.lam g hg).app a).T := by
+          simpa using hnextApp
+        have hmono : ((WShape.lam g hg).app a).T ≤
+            ((WShape.lam (g.lift k)
+              (WShapeFun.NonZero.lift_iff hk.1 |>.2 hg)).app argK).T := by
+          apply TShape.app_mono
+          · have hLift := (TShape.lift_eqv
+              (a := (WShape.lam g hg).T) (Nat.succ_le_succ hk.1)).2
+            rw [WShape.lift_lam hk.1] at hLift
+            exact hLift
+          · exact hargBound.trans (TShape.lift_eqv hk.2.1).2
+        have hT : next ≤ ((g.lift k).app argK).T := by
+          simpa [WShape.lam_eq_lam'] using hnextApp'.trans hmono
+        have hTK := (TShape.LE.def
+          (a := next) (b := ((g.lift k).app argK).T)
+          hk.2.2.2.1 (Nat.le_refl k)).1 hT
+        simpa only [nextK, WShape.lift_self] using hTK
+      have helemLe : elemHead.T ≤ (WShape.lam g hg).T := by
+        apply (TShape.LE.def (a := elemHead.T) (b := (WShape.lam g hg).T)
+          (Nat.le_refl (k + 1)) (Nat.succ_le_succ hk.1)).2
+        simp only [WShape.lift_self]
+        rw [WShape.lift_lam hk.1, WShape.lam_eq_lam']
+        apply WShape.lam'_le_lam'.2
+        obtain ⟨x, hx, hmem⟩ := (g.lift k).app_eq argK
+        exact WShapeFun.single_le.2 ⟨x, _, hmem, hx, hnextAppK⟩
+      exact ⟨elemHead.T, typeHead.T, helemLe, helemTyped.T⟩
+
+/-- Rebuild one synchronized function/type layer below a semantic RHS head.
+
+The non-structural input is `hargCap`: the semantic argument selected by the
+RHS spine must have a typed upper bound in the domain exposed by the
+registered type telescope.  Once that capture-domain link is retained, the
+singleton layer is entirely shape-theoretic.  In particular, no typing is
+pulled down through an arbitrary function observation. -/
+theorem LE_Interp.RHS.ShapeSpine.peelTypedLayer
+    {n : Nat} {g : WShapeFun n}
+    {tyDom : WShape n} {tyFun : WShapeFun n}
+    {aSp argCap : WShape n}
+    (hargCap : aSp ≤ argCap)
+    (hcapDom : argCap.HasType tyDom)
+    {next nextTy : WShape n}
+    (hnext : next ≤ g.app aSp)
+    (hnextTy : next.HasType nextTy)
+    (hnextLe : nextTy ≤ tyFun.app argCap) :
+    ∃ elem elemTy : WShape (n + 1),
+      elem ≤ .lam' g ∧ elem.HasType elemTy ∧
+        elemTy ≤ .forallE tyDom tyFun := by
+  refine ⟨.lam' (.single argCap next), .forallE tyDom (.single argCap nextTy),
+    ?_, ?_, ?_⟩
+  · apply WShape.lam'_le_lam'.2
+    obtain ⟨x', hx', hmem⟩ := g.app_eq argCap
+    exact WShapeFun.single_le.2
+      ⟨x', _, hmem, hx', hnext.trans (WShapeFun.app_mono_r hargCap)⟩
+  · apply WShape.HasType.lam
+    refine WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+    · refine WShape.HasTypePi.def.2
+        ⟨WShape.HasDom.single.2 (.inl hcapDom), ?_⟩
+      intro x y hxy
+      obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ := WShapeFun.mem_single.1 hxy
+      · exact hnextTy.isType
+      · exact .bot' .sort
+    · exact WShape.HasDom.single.2 (.inl hcapDom)
+    · simp only [WShapeFun.single_app]
+      split <;> [exact hnextTy; exact .bot' (.bot' .sort)]
+  · apply WShape.forallE_le_forallE.2
+    refine ⟨.rfl, ?_⟩
+    obtain ⟨x', hx', hmem⟩ := tyFun.app_eq argCap
+    exact WShapeFun.single_le.2 ⟨x', _, hmem, hx', hnextLe⟩
+
+/-- The recursively synchronized endpoint of a semantic RHS application
+spine.  Besides rebuilding a typed lower approximation of the term head,
+the package records that its type observation lies below the *particular*
+registered-type observation threaded through the same ordered telescope.
+
+This is intentionally a certificate over an existing `ShapeSpine`, rather
+than a pointwise family indexed by capture paths: dependent application
+requires the domain selected at one layer to determine the type observation
+used by every later layer. -/
+def LE_Interp.RHS.ShapeSpine.TypedLowerHead
+    {p : Pattern} {m2 : p.Path → TShape}
+    {head out : TShape} {paths : List p.Path}
+    (spine : LE_Interp.RHS.ShapeSpine m2 head paths out)
+    (headTy : TShape) : Prop :=
+  ∃ elem elemTy : TShape,
+    elem ≤ head ∧ elem.HasType elemTy ∧ elemTy ≤ headTy
+
+/-- An ordered type telescope synchronized with one exact semantic
+`ShapeSpine`.  The codomain observation in the recursive constructor is
+definitionally the application of the current type function to the same
+`argCap` that types the current semantic argument.  This is the dependency
+that a pointwise path map cannot express. -/
+inductive LE_Interp.RHS.ShapeSpine.TypedTelescope
+    {p : Pattern} (m2 : p.Path → TShape) :
+  ∀ {head paths out},
+      LE_Interp.RHS.ShapeSpine m2 head paths out →
+        TShape → TShape → Prop where
+  | nil (htyped : head.HasType headTy) :
+      TypedTelescope m2
+        (LE_Interp.RHS.ShapeSpine.nil (m2 := m2) (head := head))
+        headTy headTy
+  | cons
+      {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+      {m out : TShape} {path : p.Path} {paths : List p.Path}
+      {harg : a.T ≤ m2 path} {happ : m ≤ (f.app a).T}
+      {rest : LE_Interp.RHS.ShapeSpine m2 m paths out}
+      {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+      {outTy : TShape} :
+      a ≤ argCap → argCap.HasType tyDom →
+      TypedTelescope m2 rest (tyFun.app argCap).T outTy →
+      TypedTelescope m2
+        (LE_Interp.RHS.ShapeSpine.cons harg happ rest)
+        (WShape.forallE tyDom tyFun).T outTy
+
+/-- Consumer-specific evidence synchronized with an ordered typed
+telescope.  `Cap path argCap tyDom` is deliberately indexed by the exact
+argument and domain shapes stored in the telescope constructor: this keeps
+the semantic bound, typing fact, and later logical application witness from
+choosing three unrelated existential representatives.
+
+The shape module leaves `Cap` abstract.  The adequacy consumer instantiates
+it with the aligned capture relation at the logical-relation level selected
+by that application layer. -/
+inductive LE_Interp.RHS.ShapeSpine.TypedTelescope.Captures
+    {p : Pattern} {m2 : p.Path → TShape}
+    (Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop) :
+    ∀ {head out headTy outTy : TShape} {paths : List p.Path}
+      {spine : LE_Interp.RHS.ShapeSpine m2 head paths out},
+      LE_Interp.RHS.ShapeSpine.TypedTelescope
+        m2 spine headTy outTy → Prop where
+  | nil {head headTy : TShape} (htyped : head.HasType headTy) :
+      Captures Cap
+        (LE_Interp.RHS.ShapeSpine.TypedTelescope.nil htyped)
+  | cons
+      {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+      {m out : TShape} {path : p.Path} {paths : List p.Path}
+      {harg : a.T ≤ m2 path} {happ : m ≤ (f.app a).T}
+      {rest : LE_Interp.RHS.ShapeSpine m2 m paths out}
+      {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+      {outTy : TShape}
+      (hargCap : a ≤ argCap) (hcapDom : argCap.HasType tyDom)
+      {tail : LE_Interp.RHS.ShapeSpine.TypedTelescope
+        m2 rest (tyFun.app argCap).T outTy} :
+      Cap path argCap tyDom →
+      Captures Cap tail →
+      Captures Cap
+        (LE_Interp.RHS.ShapeSpine.TypedTelescope.cons
+          (harg := harg) (happ := happ)
+          hargCap hcapDom tail)
+
+/-- One ordered telescope with its consumer payload stored in the same
+constructor tree.
+
+`TypedTelescope` plus `Captures` is a useful eliminator-facing view, but the
+pair is cumbersome at a producer boundary: dependent elimination must prove
+that two separately supplied proofs describe the same layer choices.  This
+packed form makes that synchronization definitional. -/
+inductive LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+    {p : Pattern} {m2 : p.Path → TShape}
+    (Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop) :
+    TShape → List p.Path → TShape → TShape → TShape → Prop where
+  | nil (htyped : head.HasType headTy) :
+      WithCaptures Cap head [] head headTy headTy
+  | cons
+      {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+      {m out : TShape} {path : p.Path} {paths : List p.Path}
+      {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+      {outTy : TShape} :
+      a.T ≤ m2 path → m ≤ (f.app a).T →
+      a ≤ argCap → argCap.HasType tyDom →
+      Cap path argCap tyDom →
+      WithCaptures Cap m paths out (tyFun.app argCap).T outTy →
+      WithCaptures Cap f.T (path :: paths) out
+        (WShape.forallE tyDom tyFun).T outTy
+
+/-- Recover the semantic spine retained by a packed telescope. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.spine
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine m2 head paths out := by
+  induction H with
+  | nil _ => exact .nil
+  | cons harg happ _ _ _ _ ih => exact .cons harg happ ih
+
+/-- Forget a packed telescope's payload while retaining every ordered shape
+choice definitionally. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.telescope
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine.TypedTelescope
+      m2 H.spine headTy outTy := by
+  induction H with
+  | nil htyped => exact .nil htyped
+  | cons harg happ hargCap hcapDom _ _ ih =>
+    exact .cons (harg := harg) (happ := happ) hargCap hcapDom ih
+
+/-- Recover the indexed payload view when an existing consumer expects the
+older split presentation. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.captures
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.Captures
+      Cap H.telescope := by
+  induction H with
+  | nil htyped => exact .nil htyped
+  | cons harg happ hargCap hcapDom capture _ ih =>
+    exact .cons (harg := harg) (happ := happ)
+      hargCap hcapDom capture ih
+
+/-- The empty ordered telescope retains the supplied result typing
+verbatim. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedLowerHead.of_nil
+    {p : Pattern} {m2 : p.Path → TShape} {head headTy : TShape}
+    (htyped : head.HasType headTy) :
+    LE_Interp.RHS.ShapeSpine.TypedLowerHead
+      (LE_Interp.RHS.ShapeSpine.nil (m2 := m2) (head := head)) headTy :=
+  ⟨head, headTy, .rfl, htyped, .rfl⟩
+
+/-- Add one synchronized capture layer to a completed ordered telescope.
+
+The recursive certificate is anchored at the codomain observation selected
+by `argCap`.  All level changes are equivalence lifts; the only substantive
+step is `peelTypedLayer`, so no typing is pulled backwards through an
+arbitrary function-shape inequality. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedLowerHead.cons
+    {p : Pattern} {m2 : p.Path → TShape}
+    {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+    {m out : TShape} {path : p.Path} {paths : List p.Path}
+    (harg : a.T ≤ m2 path) (happ : m ≤ (f.app a).T)
+    (rest : LE_Interp.RHS.ShapeSpine m2 m paths out)
+    {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+    (hargCap : a ≤ argCap) (hcapDom : argCap.HasType tyDom)
+    (tail : LE_Interp.RHS.ShapeSpine.TypedLowerHead rest
+      (tyFun.app argCap).T) :
+    LE_Interp.RHS.ShapeSpine.TypedLowerHead
+      (LE_Interp.RHS.ShapeSpine.cons harg happ rest)
+      (WShape.forallE tyDom tyFun).T := by
+  obtain ⟨next, nextTy, hnext, hnextTy, hnextTyLe⟩ := tail
+  by_cases hnextBot : next ≤ TShape.bot
+  · exact ⟨(WShape.bot (n := n + 1)).T,
+      (WShape.bot (n := n + 1)).T, TShape.bot_le',
+      WShape.HasType.T (.bot' (.bot' .sort)), TShape.bot_le'⟩
+  have hnextApp : next ≤ (f.app a).T := hnext.trans happ
+  cases f using WShape.casesOn' with
+  | bot => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+  | sort => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+  | forallE => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+  | ctor => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+  | indTy => exact (hnextBot (hnextApp.trans TShape.bot_eqv.1)).elim
+  | @lam g hg =>
+    let k := max n (max next.1 nextTy.1)
+    have hk : n ≤ k ∧ next.1 ≤ k ∧ nextTy.1 ≤ k := by
+      dsimp [k]
+      omega
+    let aK : WShape k := a.lift k
+    let argCapK : WShape k := argCap.lift k
+    let tyDomK : WShape k := tyDom.lift k
+    let nextK : WShape k := next.2.lift k
+    let nextTyK : WShape k := nextTy.2.lift k
+    have hargCapK : aK ≤ argCapK := WShape.lift_mono hk.1 hargCap
+    have hcapDomK : argCapK.HasType tyDomK :=
+      (WShape.HasType.lift hk.1).2 hcapDom
+    have hnextAppK : nextK ≤ (g.lift k).app aK := by
+      have hnextApp' : next ≤ ((WShape.lam g hg).app a).T := by
+        simpa using hnextApp
+      have hmono : ((WShape.lam g hg).app a).T ≤
+          ((WShape.lam (g.lift k)
+            (WShapeFun.NonZero.lift_iff hk.1 |>.2 hg)).app aK).T := by
+        apply TShape.app_mono
+        · have hLift := (TShape.lift_eqv
+            (a := (WShape.lam g hg).T) (Nat.succ_le_succ hk.1)).2
+          rw [WShape.lift_lam hk.1] at hLift
+          exact hLift
+        · exact (TShape.lift_eqv hk.1).2
+      have hT : next ≤ ((g.lift k).app aK).T := by
+        simpa [WShape.lam_eq_lam'] using hnextApp'.trans hmono
+      have hTK := (TShape.LE.def
+        (a := next) (b := ((g.lift k).app aK).T)
+        hk.2.1 (Nat.le_refl k)).1 hT
+      simpa only [nextK, WShape.lift_self] using hTK
+    have hnextTyKLe : nextTyK ≤ (tyFun.lift k).app argCapK := by
+      have hTK := (TShape.LE.def
+        (a := nextTy) (b := (tyFun.app argCap).T)
+        hk.2.2 hk.1).1 hnextTyLe
+      simpa only [nextTyK, argCapK, WShape.lift_self,
+        WShapeFun.lift_app hk.1] using hTK
+    obtain ⟨elem, elemTy, helem, helemTy, helemTyLe⟩ :=
+      LE_Interp.RHS.ShapeSpine.peelTypedLayer
+        (g := g.lift k) (tyFun := tyFun.lift k)
+        hargCapK hcapDomK hnextAppK
+        ((TShape.HasType.def hk.2.1 hk.2.2).1 hnextTy)
+        hnextTyKLe
+    refine ⟨elem.T, elemTy.T, ?_, helemTy.T, ?_⟩
+    · refine helem.T.trans ?_
+      have hLift := (TShape.lift_eqv
+        (a := (WShape.lam g hg).T) (Nat.succ_le_succ hk.1)).1
+      rw [WShape.lift_lam hk.1, WShape.lam_eq_lam'] at hLift
+      exact hLift
+    · refine helemTyLe.T.trans ?_
+      have hLift := (TShape.lift_eqv
+        (a := (WShape.forallE tyDom tyFun).T)
+        (Nat.succ_le_succ hk.1)).1
+      rw [WShape.lift_forallE hk.1] at hLift
+      exact hLift
+
+/-- Forget the internal ordered layers after constructing their synchronized
+lower head and its registered-type bound. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.lowerHead
+    {p : Pattern} {m2 : p.Path → TShape}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine m2 head paths out}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope
+      m2 spine headTy outTy) :
+    spine.TypedLowerHead headTy := by
+  induction H with
+  | nil htyped => exact .of_nil htyped
+  | @cons n f a m out path paths harg happ rest tyDom tyFun argCap outTy
+      hargCap hcapDom _ ih =>
+    exact LE_Interp.RHS.ShapeSpine.TypedLowerHead.cons
+      harg happ rest hargCap hcapDom ih
+
+/-- The terminal type observation is retained as an index of the ordered
+telescope, so a later logical application fold lands at the caller's exact
+result typing rather than at an existentially chosen type shape. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.outHasType
+    {p : Pattern} {m2 : p.Path → TShape}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine m2 head paths out}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope
+      m2 spine headTy outTy) :
+    out.HasType outTy := by
+  induction H with
+  | nil htyped => exact htyped
+  | cons _ _ _ ih => exact ih
+
+/-! ### Terminal-index monotonicity for the packed ordered telescope
+
+`WithCaptures.nil` identifies the telescope's head observation with its
+terminal observation as an *index equality*.  That equality is what forces a
+finished telescope to terminate at exactly the codomain observation an ordered
+type peel reaches, while every consumer of the telescope reads its terminal
+index at the result observation its own caller already fixed.  Those two are
+independently determined, and identifying them is refutable: the corresponding
+retarget statement is `HasType`-functionality at the terminal head, and
+`TShape.HasType.bot` types `.bot` at every sort.
+
+`WithCapturesLE` is the additive repair.  Only the base changes: the terminal
+observation is recorded *below* the head observation the peel reached rather
+than equal to it, and the base typing is stated at the terminal observation —
+which is the fact a consumer's caller already holds.  Nothing else moves;
+`cons` is verbatim, so every layer is the same layer.
+
+The direction is forced by how the head index is used.  Every consumer reads it
+only as an upper bound (`TypedLowerHead` bounds the synthesized lower type by
+it; `fixedHeadShapeChain` returns `headElemTy.T ≤ headTy`), so weakening it
+upward at the base is sound and is exactly what lets a peel-reached observation
+sit above a caller-fixed one. -/
+
+/-- The packed ordered telescope with a monotone terminal index.
+
+`nil` records the caller's result-type observation `outTy` together with the
+one comparison `outTy ≤ headTy` against the observation the ordered peel
+reached.  `WithCaptures` is the special case `outTy = headTy`
+(`WithCaptures.toLE`). -/
+inductive LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+    {p : Pattern} {m2 : p.Path → TShape}
+    (Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop) :
+    TShape → List p.Path → TShape → TShape → TShape → Prop where
+  | nil {head headTy outTy : TShape}
+      (htyped : head.HasType outTy) (hle : outTy ≤ headTy) :
+      WithCapturesLE Cap head [] head headTy outTy
+  | cons
+      {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+      {m out : TShape} {path : p.Path} {paths : List p.Path}
+      {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+      {outTy : TShape} :
+      a.T ≤ m2 path → m ≤ (f.app a).T →
+      a ≤ argCap → argCap.HasType tyDom →
+      Cap path argCap tyDom →
+      WithCapturesLE Cap m paths out (tyFun.app argCap).T outTy →
+      WithCapturesLE Cap f.T (path :: paths) out
+        (WShape.forallE tyDom tyFun).T outTy
+
+/-- Faithfulness: the exact packed telescope is the reflexive case of the
+monotone one, so every producer of the old form still supplies the new. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.toLE
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := m2) Cap head paths out headTy outTy := by
+  induction H with
+  | nil htyped => exact .nil htyped TShape.LE.rfl
+  | cons harg happ hargCap hcapDom capture _ ih =>
+    exact .cons harg happ hargCap hcapDom capture ih
+
+/-- **THE TERMINAL-INDEX MONOTONICITY.**  A finished telescope may be read at
+any result observation below the one it terminates at, provided that
+observation types the spine's result.
+
+This is the lemma `WithCaptures` cannot have: its `nil` identifies the two
+indices, so the rebuild has to happen at the base, and only the monotone base
+admits it.  Both extra inputs are held by the consumer's caller — `htyped` is
+the caller's own `out.HasType outTy`, and `hle` is the single residual
+comparison against the observation the ordered peel reached. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.retarget
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy reachedTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := m2) Cap head paths out headTy reachedTy)
+    (htyped : out.HasType outTy) (hle : outTy ≤ reachedTy) :
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := m2) Cap head paths out headTy outTy := by
+  induction H with
+  | nil _ => exact .nil htyped hle
+  | cons harg happ hargCap hcapDom capture _ ih =>
+    exact .cons harg happ hargCap hcapDom capture (ih htyped hle)
+
+/-- Recover the semantic spine retained by a monotone packed telescope. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.spine
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine m2 head paths out := by
+  induction H with
+  | nil _ _ => exact .nil
+  | cons harg happ _ _ _ _ ih => exact .cons harg happ ih
+
+/-- The monotone telescope still lands at the caller's exact result typing:
+that fact is what its base now records directly. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.outHasType
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := m2) Cap head paths out headTy outTy) :
+    out.HasType outTy := by
+  induction H with
+  | nil htyped _ => exact htyped
+  | cons _ _ _ _ _ _ ih => exact ih
+
+/-- The synchronized lower head survives the weakening: the head observation
+is used only as an upper bound, and the base now bounds the caller's result
+observation by the reached one. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.lowerHead
+    {p : Pattern} {m2 : p.Path → TShape}
+    {Cap : ∀ {n}, p.Path → WShape n → WShape n → Prop}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := m2) Cap head paths out headTy outTy) :
+    LE_Interp.RHS.ShapeSpine.TypedLowerHead H.spine headTy := by
+  induction H with
+  | nil htyped hle => exact ⟨_, _, TShape.LE.rfl, htyped, hle⟩
+  | cons harg happ hargCap hcapDom _ tail ih =>
+    exact LE_Interp.RHS.ShapeSpine.TypedLowerHead.cons
+      harg happ tail.spine hargCap hcapDom ih
+
+/-- Extract the semantic application chain from an `appN` tower of capture
+variables.  A proof may interpret any syntax as bottom; otherwise its head
+is an interpretation of the fixed tower and every capture application is
+retained in `ShapeSpine`. -/
+theorem LE_Interp.RHS.appN_vars
+    (H : LE_Interp.RHS ls m2 R out
+      (Pattern.RHS.appN f (paths.map fun path => .var path))) :
+    out ≤ TShape.bot ∨
+      ∃ head, LE_Interp.RHS ls m2 R head f ∧
+        LE_Interp.RHS.ShapeSpine m2 head paths out := by
+  induction paths generalizing f out with
+  | nil =>
+    exact .inr ⟨out, H, .nil⟩
+  | cons path paths ih =>
+    simp only [List.map_cons, Pattern.RHS.appN] at H
+    obtain hout | ⟨head, hhead, hspine⟩ := ih H
+    · exact .inl hout
+    · cases hhead with
+      | bot => exact .inl (hspine.le_bot TShape.bot_eqv.1)
+      | app hf ha happ =>
+        exact .inr ⟨_, hf, .cons ha.var_le happ hspine⟩
+
+/-- Specialize `appN_vars` to the fixed tower and ordered capture inventory
+stored by a generated iota rule. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.rhsShapeSpine
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r)
+    {ls : List SLevel}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape}
+    {R : TShape → SExpr → Prop} {out : TShape}
+    (H : LE_Interp.RHS ls mcap R out r.1) :
+    out ≤ TShape.bot ∨
+      ∃ head,
+        LE_Interp.RHS ls mcap R head (.fixed rule.df.rhs rule.rhsClosed) ∧
+        LE_Interp.RHS.ShapeSpine mcap head rule.capturePaths out := by
+  rw [rule.rhsTower] at H
+  exact H.appN_vars
+
 variable (c : Name) (ls : List SLevel) (R : TShape → SExpr → Prop) {n : Nat} in
 inductive LE_Interp.Const : List (WShape n) → TShape → Prop
   | bot : Const rargs (WShape.T (n := n') .bot)
@@ -3335,10 +4032,788 @@ inductive LE_Interp : Valuation → TShape → SExpr → Prop
   | const :
     Params.env.constants c = some ci → ls.length = ci.uvars →
     m ≤ m' → m'.HasType a →
-    LE_Interp ρ a ((SExpr.mk ci.type).instL ls) →
+    LE_Interp ρ a (SExpr.mkInst ls ci.type) →
     LE_Interp.Const c ls R [] m' → (∀ m e, R m e → LE_Interp ρ m e) →
     LE_Interp ρ m (.const c ls)
 
+/-! #### Proof-relevant interpretation witnesses
+
+`LE_Interp` remains a proposition: all public semantic statements should be
+proof-irrelevant.  Its derivation tree, however, cannot itself be used as a
+recursion certificate.  Proof irrelevance identifies two derivations at the
+same indices, including derivations that chose different abstract relations
+in the constant case.  A predicate indexed by an `LE_Interp` proof therefore
+cannot remember which `R` witness an evaluator actually exposed.
+
+`LE_Interp.Witness` is the proof-relevant mirror used only at that internal
+recursion boundary.  Every propositional interpretation has a witness, and a
+witness forgets back to the original proposition.  Choosing a witness is
+noncomputable but adds no semantic assumption; it merely retains one
+consistent constructor tree through recursive constant evaluation. -/
+
+inductive LE_Interp.Witness : Valuation → TShape → SExpr → Type where
+  | bot : Witness ρ (WShape.T (n := n) .bot) M
+  | bvar : m ≤ ρ i → Witness ρ m (.bvar i)
+  | sort : m ≤ .sort (l ≠ .zero) → Witness ρ m (.sort l)
+  | app : Witness ρ (WShape.T f) F → Witness ρ a.T A →
+    m ≤ (f.app a).T → Witness ρ m (.app F A)
+  | lam : Witness ρ (WShape.T (n := n) a) A →
+    WShape.HasDom f a →
+    (∀ x, x.HasType a → Witness (ρ.push x.T) (f.app x).T F) →
+    m ≤ WShape.T (n := _ + 1) (.lam' f) → Witness ρ m (.lam A F)
+  | forallE : Witness ρ (WShape.T (n := n) b) B →
+    Witness ρ (WShape.T (n := n) b') B →
+    WShape.HasDom f b' →
+    (∀ x, x.HasType b' → Witness (ρ.push x.T) (f.app x).T F) →
+    m ≤ WShape.T (n := n + 1) (.forallE b f) → Witness ρ m (.forallE B F)
+  | const :
+    Params.env.constants c = some ci → ls.length = ci.uvars →
+    m ≤ m' → m'.HasType a →
+    Witness ρ a (SExpr.mkInst ls ci.type) →
+    LE_Interp.Const c ls R [] m' →
+    (∀ m e, R m e → Witness ρ m e) →
+    Witness ρ m (.const c ls)
+
+/-- Forget the proof-relevant recursion witness. -/
+theorem LE_Interp.Witness.toInterp :
+    LE_Interp.Witness ρ m M → LE_Interp ρ m M
+  | .bot => .bot
+  | .bvar h => .bvar h
+  | .sort h => .sort h
+  | .app hf ha h => .app hf.toInterp ha.toInterp h
+  | .lam ha hdom hbody h =>
+      .lam ha.toInterp hdom (fun x hx => (hbody x hx).toInterp) h
+  | .forallE hb hb' hdom hbody h =>
+      .forallE hb.toInterp hb'.toInterp hdom
+        (fun x hx => (hbody x hx).toInterp) h
+  | .const hreg hlen hle hty hA hC hR =>
+      .const hreg hlen hle hty hA.toInterp hC
+        (fun m e hr => (hR m e hr).toInterp)
+
+/-- Every propositional interpretation contains at least one consistent
+proof-relevant constructor tree. -/
+theorem LE_Interp.witnessNonempty (H : LE_Interp ρ m M) :
+    Nonempty (LE_Interp.Witness ρ m M) := by
+  induction H with
+  | bot => exact ⟨LE_Interp.Witness.bot⟩
+  | bvar h => exact ⟨LE_Interp.Witness.bvar h⟩
+  | sort h => exact ⟨LE_Interp.Witness.sort h⟩
+  | app hf ha h ihf iha =>
+    exact ⟨LE_Interp.Witness.app (Classical.choice ihf) (Classical.choice iha) h⟩
+  | lam ha hdom hbody h iha ihbody =>
+    exact ⟨LE_Interp.Witness.lam (Classical.choice iha) hdom
+      (fun x hx => Classical.choice (ihbody x hx)) h⟩
+  | forallE hb hb' hdom hbody h ihb ihb' ihbody =>
+    exact ⟨LE_Interp.Witness.forallE (Classical.choice ihb)
+      (Classical.choice ihb') hdom
+      (fun x hx => Classical.choice (ihbody x hx)) h⟩
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    exact ⟨LE_Interp.Witness.const hreg hlen hle hty
+      (Classical.choice ihA) hC
+      (fun m e hr => Classical.choice (ihR m e hr))⟩
+
+/-- Choose the internal constructor tree used by a recursive semantic
+consumer.  Consumers must remain proof-independent after forgetting it. -/
+noncomputable def LE_Interp.witness (H : LE_Interp ρ m M) :
+    LE_Interp.Witness ρ m M :=
+  Classical.choice H.witnessNonempty
+
+theorem LE_Interp.witness_toInterp (H : LE_Interp ρ m M) :
+    H.witness.toInterp = H :=
+  Subsingleton.elim _ _
+
+/-- Lower the root observation without changing the chosen constructor tree
+or any abstract relation witness stored below it. -/
+def LE_Interp.Witness.mono (h : m ≤ m') :
+    LE_Interp.Witness ρ m' M → LE_Interp.Witness ρ m M
+  | .bot =>
+      TShape.le_bot'.1 (h.trans TShape.bot_eqv.1) ▸ .bot
+  | .bvar h₁ => .bvar (h.trans h₁)
+  | .sort h₁ => .sort (h.trans h₁)
+  | .app hf ha h₁ => .app hf ha (h.trans h₁)
+  | .lam ha hdom hbody h₁ => .lam ha hdom hbody (h.trans h₁)
+  | .forallE hb hb' hdom hbody h₁ =>
+      .forallE hb hb' hdom hbody (h.trans h₁)
+  | .const hreg hlen hle hty hA hC hR =>
+      .const hreg hlen (h.trans hle) hty hA hC hR
+
+/-- Turn a synchronized ordered-telescope type bound into the exact
+proof-relevant type witness required by the fixed-head consumer. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedLowerHead.withWitness
+    {p : Pattern} {m2 : p.Path → TShape}
+    {head out headTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine m2 head paths out}
+    (H : spine.TypedLowerHead headTy)
+    (hTy : LE_Interp.Witness ρ headTy A) :
+    ∃ elem elemTy : TShape,
+      elem ≤ head ∧ elem.HasType elemTy ∧
+        Nonempty (LE_Interp.Witness ρ elemTy A) := by
+  obtain ⟨elem, elemTy, helem, htyped, hty⟩ := H
+  exact ⟨elem, elemTy, helem, htyped, ⟨hTy.mono hty⟩⟩
+
+/-- Enlarge a valuation while retaining the same proof-relevant semantic
+tree. -/
+def LE_Interp.Witness.mono_l (hρ : ρ.LE ρ') :
+    LE_Interp.Witness ρ m M → LE_Interp.Witness ρ' m M
+  | .bot => .bot
+  | .bvar hle => .bvar (hle.trans (hρ _))
+  | .sort hle => .sort hle
+  | .app hf ha hle => .app (hf.mono_l hρ) (ha.mono_l hρ) hle
+  | .lam ha hdom hbody hle =>
+      .lam (ha.mono_l hρ) hdom
+        (fun x hx => (hbody x hx).mono_l
+          (Valuation.LE.push.2 ⟨hρ, .rfl⟩)) hle
+  | .forallE hb hb' hdom hbody hle =>
+      .forallE (hb.mono_l hρ) (hb'.mono_l hρ) hdom
+        (fun x hx => (hbody x hx).mono_l
+          (Valuation.LE.push.2 ⟨hρ, .rfl⟩)) hle
+  | .const hreg hlen hle hty hA hC hR =>
+      .const hreg hlen hle hty (hA.mono_l hρ) hC
+        (fun m e hr => (hR m e hr).mono_l hρ)
+
+/-- Well-founded recursion through the abstract `R` leaves of one chosen
+interpretation tree.  Unlike `LE_Interp.recR`, the recursive hypothesis is
+attached to the proof-relevant witness that supplied the leaf. -/
+theorem LE_Interp.Witness.recR
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      (match H with
+       | .const _ _ _ _ _ _ hR => ∀ m e hr, P (hR m e hr)
+       | _ => True) → P H)
+    {rho m M} (H : LE_Interp.Witness rho m M) : P H := by
+  induction H with
+  | bot => exact step _ trivial
+  | bvar => exact step _ trivial
+  | sort => exact step _ trivial
+  | app => exact step _ trivial
+  | lam => exact step _ trivial
+  | forallE => exact step _ trivial
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    exact step _ ihR
+
+/-- Regard a predicate on public semantic indices as a predicate on a
+proof-relevant witness. -/
+abbrev LE_Interp.Witness.AtIndices
+    (P : Valuation → TShape → SExpr → Prop)
+    {ρ m M} (_ : LE_Interp.Witness ρ m M) : Prop :=
+  P ρ m M
+
+/-- Proof-independent specialization of `Witness.recR`.  This is the form
+an adequacy consumer should expose: the chosen witness controls recursive
+calls, but the theorem proved at each node depends only on its public
+semantic indices. -/
+theorem LE_Interp.Witness.recRIndex
+    {P : Valuation → TShape → SExpr → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      (match H with
+       | .const _ _ _ _ _ _ hR => ∀ m e hr, AtIndices P (hR m e hr)
+       | _ => True) → AtIndices P H)
+    {rho m M} (H : LE_Interp.Witness rho m M) : P rho m M :=
+  H.recR (P := AtIndices P) step
+
+/-- Recursive results attached to every immediate child of one exact
+proof-relevant interpretation tree. -/
+def LE_Interp.Witness.DeepChildren
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    {ρ m M} (H : LE_Interp.Witness ρ m M) : Prop :=
+  match H with
+  | .app hf ha _ => P hf ∧ P ha
+  | .lam ha _ hbody _ => P ha ∧ ∀ x hx, P (hbody x hx)
+  | .forallE hb hb' _ hbody _ =>
+      P hb ∧ P hb' ∧ ∀ x hx, P (hbody x hx)
+  | .const _ _ _ _ hA _ hR =>
+      P hA ∧ ∀ m e hr, P (hR m e hr)
+  | _ => True
+
+/-- Structural recursion through one complete proof-relevant interpretation
+tree.  Unlike `recR`, the step receives recursive results for ordinary
+syntax/type children as well as the exact constant relation children.  This
+is the semantic half of the stratified self-validity induction. -/
+theorem LE_Interp.Witness.recDeep
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      H.DeepChildren P → P H)
+    {rho m M} (H : LE_Interp.Witness rho m M) : P H := by
+  induction H with
+  | bot => exact step _ trivial
+  | bvar => exact step _ trivial
+  | sort => exact step _ trivial
+  | app hf ha hle ihf iha => exact step _ ⟨ihf, iha⟩
+  | lam ha hdom hbody hle iha ihbody =>
+    exact step _ ⟨iha, ihbody⟩
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    exact step _ ⟨ihb, ihb', ihbody⟩
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    exact step _ ⟨ihA, ihR⟩
+
+/-- Nested structural recursion over two exact interpretation trees.  The
+first tree's child hypotheses are polymorphic in the second tree, so an
+inner syntactic proof may swap the displayed term/type roles without losing
+either tree's recursive constant callbacks. -/
+theorem LE_Interp.Witness.recDeep₂
+    {P : ∀ {ρm m M ρa a A},
+      LE_Interp.Witness ρm m M → LE_Interp.Witness ρa a A → Prop}
+    (step : ∀ {ρm m M ρa a A}
+        (hM : LE_Interp.Witness ρm m M)
+        (hA : LE_Interp.Witness ρa a A),
+      hM.DeepChildren
+        (fun hM' => ∀ {ρa a A} (hA' : LE_Interp.Witness ρa a A),
+          P hM' hA') →
+      hA.DeepChildren (fun hA' => P hM hA') →
+      P hM hA)
+    {rhom m M rhoa a A}
+    (hM : LE_Interp.Witness rhom m M)
+    (hA : LE_Interp.Witness rhoa a A) : P hM hA := by
+  refine hM.recDeep
+    (P := fun hM => ∀ {rhoa a A}
+      (hA : LE_Interp.Witness rhoa a A), P hM hA) ?_ hA
+  intro rhom m M hM childrenM rhoa a A hA
+  exact hA.recDeep
+    (P := fun hA => P hM hA)
+    (fun hA childrenA => step hM hA childrenM childrenA)
+
+/-- The complete proof-relevant witness tree for a consumer that recurses
+only at abstract constant `R` edges.  Ordinary syntax children retain their
+exact constructor trees, so a nested stratified induction may descend into
+them without treating that descent as a semantic recursive call.
+
+This is the proof-relevant counterpart of `LE_Interp.RDeepChildren`.
+Unlike the propositional version, every retained child preserves the exact
+constant relation and callback selected by the evaluator. -/
+inductive LE_Interp.Witness.RDeepChildren
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop) :
+    ∀ {ρ m M} (H : LE_Interp.Witness ρ m M), Prop where
+  | bot : RDeepChildren P (.bot (ρ := ρ) (M := M) (n := n))
+  | bvar : RDeepChildren P (.bvar h)
+  | sort : RDeepChildren P (.sort h)
+  | app : RDeepChildren P hf → RDeepChildren P ha →
+      RDeepChildren P (.app hf ha h)
+  | lam : RDeepChildren P ha →
+      (∀ x hx, RDeepChildren P (hbody x hx)) →
+      RDeepChildren P (.lam ha hdom hbody h)
+  | forallE : RDeepChildren P hb → RDeepChildren P hb' →
+      (∀ x hx, RDeepChildren P (hbody x hx)) →
+      RDeepChildren P (.forallE hb hb' hdom hbody h)
+  | const : RDeepChildren P hA →
+      (∀ m e hr, P (hR m e hr)) →
+      (∀ m e hr, RDeepChildren P (hR m e hr)) →
+      RDeepChildren P (.const hreg hlen hle hty hA hC hR)
+
+/-- Algebraic closure needed to merge two exact retained trees.  The join
+law deliberately quantifies over the selected joined witness: compatible
+constant evaluators construct that witness from their proof-relevant
+callbacks, rather than reselecting a propositional interpretation. -/
+structure LE_Interp.Witness.RDeepChildren.JoinLaws
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop) : Prop where
+  bot : ∀ {ρ n M},
+    P (LE_Interp.Witness.bot (ρ := ρ) (n := n) (M := M))
+  mono : ∀ {ρ m m' M} (H : LE_Interp.Witness ρ m' M)
+    (hle : m ≤ m'), P H → P (H.mono hle)
+  mono_l : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+    (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ)
+  join : ∀ {ρ m₁ m₂ M}
+    (H₁ : LE_Interp.Witness ρ m₁ M)
+    (H₂ : LE_Interp.Witness ρ m₂ M)
+    (HJ : LE_Interp.Witness ρ (m₁.join m₂) M),
+    P H₁ → P H₂ → P HJ
+
+/-- Change the recursive-result predicate throughout a retained tree without
+changing any exact witness or evaluator callback. -/
+theorem LE_Interp.Witness.RDeepChildren.map
+    {P Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hPQ : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M), P H → Q H)
+    {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P) : H.RDeepChildren Q := by
+  induction children with
+  | bot => exact .bot
+  | bvar => exact .bvar
+  | sort => exact .sort
+  | app _ _ ihf iha => exact .app ihf iha
+  | lam _ _ iha ihbody => exact .lam iha ihbody
+  | forallE _ _ _ ihb ihb' ihbody => exact .forallE ihb ihb' ihbody
+  | const _ pR _ ihA ihR =>
+    exact .const ihA (fun m e hr => hPQ _ (pR m e hr)) ihR
+
+/-- Lowering only the root observation of an exact witness preserves its
+complete retained recursion tree.  In particular, the abstract relation and
+every proof-relevant `R` callback in a constant witness are definitionally
+the same after lowering; no transport law for the recursive predicate is
+needed. -/
+theorem LE_Interp.Witness.RDeepChildren.mono
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    {H : LE_Interp.Witness ρ m' M}
+    (children : H.RDeepChildren P) (hle : m ≤ m') :
+    (H.mono hle).RDeepChildren P := by
+  cases H with
+  | @bot ρ n M =>
+    cases children
+    rcases m with ⟨k, s⟩
+    have hs : s = .bot :=
+      TShape.le_bot.1 (hle.trans TShape.bot_eqv.1)
+    subst s
+    simp only [LE_Interp.Witness.mono]
+    exact .bot
+  | bvar h =>
+    cases children
+    exact .bvar
+  | sort h =>
+    cases children
+    exact .sort
+  | app hf ha h =>
+    cases children with
+    | app cf ca => exact .app cf ca
+  | lam ha hdom hbody h =>
+    cases children with
+    | lam ca cbody => exact .lam ca cbody
+  | forallE hb hb' hdom hbody h =>
+    cases children with
+    | forallE cb cb' cbody => exact .forallE cb cb' cbody
+  | const hreg hlen hle' hty hA hC hR =>
+    cases children with
+    | const cA pR cR => exact .const cA pR cR
+
+/-- Enlarge the valuation throughout a retained exact recursion tree.
+
+Unlike root lowering, valuation enlargement also transforms every recursive
+`R` child.  The caller therefore supplies the corresponding transport law
+for the recursive result predicate.  Quantifying that law over arbitrary
+valuations is essential below binders, where the recursive call uses the
+pointwise enlarged pushed valuation. -/
+theorem LE_Interp.Witness.RDeepChildren.mono_l
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P) (hρ : ρ.LE ρ') :
+    (H.mono_l hρ).RDeepChildren P := by
+  induction H generalizing ρ' with
+  | @bot ρ n M =>
+    cases children
+    cases M <;> exact .bot
+  | bvar hle =>
+    cases children
+    exact .bvar
+  | sort hle =>
+    cases children
+    exact .sort
+  | app hf ha hle ihf iha =>
+    cases children with
+    | app cf ca => exact .app (ihf cf hρ) (iha ca hρ)
+  | lam ha hdom hbody hle iha ihbody =>
+    cases children with
+    | lam ca cbody =>
+      exact .lam (iha ca hρ) (fun x hx =>
+        ihbody x hx (cbody x hx)
+          (Valuation.LE.push.2 ⟨hρ, .rfl⟩))
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    cases children with
+    | forallE cb cb' cbody =>
+      exact .forallE (ihb cb hρ) (ihb' cb' hρ) (fun x hx =>
+        ihbody x hx (cbody x hx)
+          (Valuation.LE.push.2 ⟨hρ, .rfl⟩))
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    cases children with
+    | const cA pR cR =>
+      exact .const (ihA cA hρ)
+        (fun m e hr => hP (hR m e hr) hρ (pR m e hr))
+        (fun m e hr => ihR m e hr (cR m e hr) hρ)
+
+/-- Well-founded recursion through one exact witness tree, granting the
+recursive predicate only at abstract constant `R` edges.  The result is
+paired with the complete retained tree so an enclosing syntax-indexed
+induction can continue through ordinary children before taking another
+semantic edge. -/
+theorem LE_Interp.Witness.recRDeep
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      H.RDeepChildren P → P H)
+    {ρ m M} (H : LE_Interp.Witness ρ m M) : P H := by
+  suffices P H ∧ H.RDeepChildren P from this.1
+  induction H with
+  | bot => exact ⟨step _ .bot, .bot⟩
+  | bvar h => exact ⟨step _ (.bvar (h := h)), .bvar (h := h)⟩
+  | sort h => exact ⟨step _ (.sort (h := h)), .sort (h := h)⟩
+  | app hf ha h ihf iha =>
+    exact ⟨step _ (.app (h := h) ihf.2 iha.2),
+      .app (h := h) ihf.2 iha.2⟩
+  | lam ha hdom hbody h iha ihbody =>
+    exact ⟨step _ (.lam (hdom := hdom) (hbody := hbody) (h := h)
+        iha.2 (fun x hx => (ihbody x hx).2)),
+      .lam (hdom := hdom) (hbody := hbody) (h := h)
+        iha.2 (fun x hx => (ihbody x hx).2)⟩
+  | forallE hb hb' hdom hbody h ihb ihb' ihbody =>
+    exact ⟨step _ (.forallE (hdom := hdom) (hbody := hbody) (h := h)
+        ihb.2 ihb'.2 (fun x hx => (ihbody x hx).2)),
+      .forallE (hdom := hdom) (hbody := hbody) (h := h)
+        ihb.2 ihb'.2 (fun x hx => (ihbody x hx).2)⟩
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    exact ⟨step _ (.const (hreg := hreg) (hlen := hlen) (hle := hle)
+        (hty := hty) (hC := hC) ihA.2 (fun m e hr => (ihR m e hr).1)
+        (fun m e hr => (ihR m e hr).2)),
+      .const (hreg := hreg) (hlen := hlen) (hle := hle)
+        (hty := hty) (hC := hC) ihA.2 (fun m e hr => (ihR m e hr).1)
+        (fun m e hr => (ihR m e hr).2)⟩
+
+/-- Rebuild a complete retained tree from a local result constructor.
+
+The constructor is invoked only after the corresponding witness's genuine
+`R` children have themselves been rebuilt.  This is the proof-relevant
+operation needed at a strict Nat decrease: a converted endpoint may select a
+fresh exact witness, but no recursive result is attached until structural
+semantic descent has exposed its actual evaluator children. -/
+theorem LE_Interp.Witness.RDeepChildren.of_step
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      H.RDeepChildren P → P H)
+    {rho m M} (H : LE_Interp.Witness rho m M) :
+    H.RDeepChildren P := by
+  induction H with
+  | bot => exact .bot
+  | bvar => exact .bvar
+  | sort => exact .sort
+  | app _ _ _ ihf iha => exact .app ihf iha
+  | lam _ _ _ _ iha ihbody => exact .lam iha ihbody
+  | forallE _ _ _ _ _ ihb ihb' ihbody =>
+    exact .forallE ihb ihb' ihbody
+  | const _ _ _ _ _ _ hR ihA ihR =>
+    exact .const ihA (fun m e hr => step (hR m e hr) (ihR m e hr)) ihR
+
+/-- Lexicographic recursion over one exact semantic tree and a syntactic
+depth.
+
+Abstract constant `R` edges receive the recursive result at every depth.
+Ordinary semantic children retain only their exact trees, but a restart at
+one of those children may be made after strictly lowering `d`.  Unlike the
+binary eliminator below, this form deliberately leaves any displayed type
+witness outside the semantic recursion.  It is the right interface when a
+proof-relevant soundness package constructs the retained result-type tree
+from the subject tree instead of recursively selecting an unrelated type
+witness. -/
+theorem LE_Interp.Witness.recRDeepNat
+    {Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' => ∀ d, Q hM' d) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρ m M} (hM' : LE_Interp.Witness ρ m M),
+          hM'.RDeepChildren (fun hM'' => ∀ d, Q hM'' d) →
+          Q hM' d') →
+      Q hM d)
+    {rho m M} (hM : LE_Interp.Witness rho m M) : ∀ d, Q hM d := by
+  let P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop :=
+    fun hM => ∀ d, Q hM d
+  apply hM.recRDeep (P := P)
+  intro ρ m M hM children
+  let motive := fun d =>
+    ∀ {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' => ∀ d, Q hM' d) → Q hM d
+  have go : ∀ d, motive d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρ m M hM children
+      exact step d hM children
+        (fun d' hd' {_ _ _} hM' children' =>
+          ih d' hd' hM' children')
+  exact fun d => go d hM children
+
+/-- Lexicographic recursion with syntactic depth as the primary component
+and exact semantic-tree descent as the secondary component.
+
+At a fixed depth, abstract constant `R` edges receive the recursive result
+by structural descent through the selected witness.  After strictly lowering
+the depth, the continuation may restart from any exact witness; its retained
+tree is rebuilt by the semantic recursor rather than required from the
+caller.  This ordering is the conversion-compatible form of the recursion. -/
+theorem LE_Interp.Witness.recNatRDeep
+    {Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' => Q hM' d) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρ m M} (hM' : LE_Interp.Witness ρ m M), Q hM' d') →
+      Q hM d)
+    {rho m M} (hM : LE_Interp.Witness rho m M) : ∀ d, Q hM d := by
+  have go : ∀ d, ∀ {ρ m M}
+      (hM : LE_Interp.Witness ρ m M), Q hM d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρ m M hM
+      exact hM.recRDeep
+        (P := fun hM => Q hM d)
+        (fun hM children => step d hM children
+          (fun d' hd' {_ _ _} hM' => ih d' hd' hM'))
+  exact fun d => go d hM
+
+/-- Nested proof-relevant `R`-edge recursion.  The first exact tree remains
+available while traversing the second, and ordinary children on either side
+retain their evaluator provenance for the inner stratified induction. -/
+theorem LE_Interp.Witness.recRDeep₂
+    {P : ∀ {ρm m M ρa a A},
+      LE_Interp.Witness ρm m M → LE_Interp.Witness ρa a A → Prop}
+    (step : ∀ {ρm m M ρa a A}
+        (hM : LE_Interp.Witness ρm m M)
+        (hA : LE_Interp.Witness ρa a A),
+      hM.RDeepChildren
+          (fun hM' => ∀ {ρa a A} (hA' : LE_Interp.Witness ρa a A),
+            P hM' hA') →
+      hA.RDeepChildren (fun hA' => P hM hA') →
+      P hM hA)
+    {ρm m M ρa a A}
+    (hM : LE_Interp.Witness ρm m M)
+    (hA : LE_Interp.Witness ρa a A) : P hM hA := by
+  refine hM.recRDeep
+    (P := fun hM => ∀ {ρa a A}
+      (hA : LE_Interp.Witness ρa a A), P hM hA) ?_ hA
+  intro ρm m M hM childrenM ρa a A hA
+  exact hA.recRDeep
+    (P := fun hA => P hM hA)
+    (fun hA childrenA => step hM hA childrenM childrenA)
+
+/-- Lexicographic recursion over two exact semantic trees and a syntactic
+depth.
+
+Abstract constant `R` edges receive the recursive result at every depth and
+may therefore restart a typing derivation.  Every other recursive restart may
+select new exact witnesses (which is needed by conversion and dependent
+application), but must strictly lower `d`.  This is the eliminator used by
+fixed-head self-validity: it makes the two independent decreases explicit
+without assigning a numeric size to proof-relevant evaluator callbacks. -/
+theorem LE_Interp.Witness.recRDeep₂Nat
+    {Q : ∀ {ρm m M ρa a A},
+      LE_Interp.Witness ρm m M → LE_Interp.Witness ρa a A → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρm m M ρa a A}
+        (hM : LE_Interp.Witness ρm m M)
+        (hA : LE_Interp.Witness ρa a A),
+      hM.RDeepChildren
+          (fun hM' => ∀ {ρa a A} (hA' : LE_Interp.Witness ρa a A),
+            ∀ d, Q hM' hA' d) →
+      hA.RDeepChildren (fun hA' => ∀ d, Q hM hA' d) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρm m M ρa a A}
+          (hM' : LE_Interp.Witness ρm m M)
+          (hA' : LE_Interp.Witness ρa a A),
+        hM'.RDeepChildren
+            (fun hM'' => ∀ {ρa a A}
+              (hA'' : LE_Interp.Witness ρa a A), ∀ d, Q hM'' hA'' d) →
+        hA'.RDeepChildren (fun hA'' => ∀ d, Q hM' hA'' d) →
+        Q hM' hA' d') →
+      Q hM hA d)
+    {rhom m M rhoa a A}
+    (hM : LE_Interp.Witness rhom m M)
+    (hA : LE_Interp.Witness rhoa a A) : ∀ d, Q hM hA d := by
+  let P : ∀ {ρm m M ρa a A},
+      LE_Interp.Witness ρm m M → LE_Interp.Witness ρa a A → Prop :=
+    fun hM hA => ∀ d, Q hM hA d
+  apply hM.recRDeep₂ (P := P) (hA := hA)
+  intro ρm m M ρa a A hM hA childrenM childrenA
+  let motive := fun d =>
+    ∀ {ρm m M ρa a A}
+      (hM : LE_Interp.Witness ρm m M)
+      (hA : LE_Interp.Witness ρa a A),
+      hM.RDeepChildren
+          (fun hM' => ∀ {ρa a A} (hA' : LE_Interp.Witness ρa a A),
+            ∀ d, Q hM' hA' d) →
+      hA.RDeepChildren (fun hA' => ∀ d, Q hM hA' d) →
+      Q hM hA d
+  have go : ∀ d, motive d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρm m M ρa a A hM hA childrenM childrenA
+      exact step d hM hA childrenM childrenA
+        (fun d' hd' {_ _ _ _ _ _} hM' hA' childrenM' childrenA' =>
+          ih d' hd' hM' hA' childrenM' childrenA')
+  exact fun d => go d hM hA childrenM childrenA
+
+/-- Nat-first nested recursion over two exact semantic trees.
+
+Both trees are traversed structurally at the current syntactic depth.  A
+strict depth decrease then permits an arbitrary new pair of witnesses, which
+is needed when application swaps the term/type roles and conversion replaces
+the displayed type witness. -/
+theorem LE_Interp.Witness.recNatRDeep₂
+    {Q : ∀ {ρm m M ρa a A},
+      LE_Interp.Witness ρm m M → LE_Interp.Witness ρa a A → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρm m M ρa a A}
+        (hM : LE_Interp.Witness ρm m M)
+        (hA : LE_Interp.Witness ρa a A),
+      hM.RDeepChildren
+          (fun hM' => ∀ {ρa a A} (hA' : LE_Interp.Witness ρa a A),
+            Q hM' hA' d) →
+      hA.RDeepChildren (fun hA' => Q hM hA' d) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρm m M ρa a A}
+          (hM' : LE_Interp.Witness ρm m M)
+          (hA' : LE_Interp.Witness ρa a A),
+        Q hM' hA' d') →
+      Q hM hA d)
+    {rhom m M rhoa a A}
+    (hM : LE_Interp.Witness rhom m M)
+    (hA : LE_Interp.Witness rhoa a A) : ∀ d, Q hM hA d := by
+  have go : ∀ d, ∀ {ρm m M ρa a A}
+      (hM : LE_Interp.Witness ρm m M)
+      (hA : LE_Interp.Witness ρa a A), Q hM hA d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρm m M ρa a A hM hA
+      exact hM.recRDeep₂ (hA := hA)
+        (P := fun hM hA => Q hM hA d)
+        (fun hM hA childrenM childrenA =>
+          step d hM hA childrenM childrenA
+            (fun d' hd' {_ _ _ _ _ _} hM' hA' =>
+              ih d' hd' hM' hA'))
+  exact fun d => go d hM hA
+
+/-- The recursive interpretations exposed by a propositional constant
+derivation.  Ordinary syntax children are deliberately absent.
+
+Because `LE_Interp` is a proposition, this interface is suitable only when
+`P` is insensitive to the particular derivation chosen at fixed indices.
+Use `LE_Interp.Witness` when a consumer must retain the exact abstract
+relation and recursive callback supplied by one constructor tree. -/
+inductive LE_Interp.RChildren
+    (P : ∀ {ρ m M}, LE_Interp ρ m M → Prop) :
+    ∀ {ρ m M}, LE_Interp ρ m M → Prop where
+  | bot : RChildren P (.bot (ρ := ρ) (M := M) (n := n))
+  | bvar : RChildren P (.bvar (ρ := ρ) (i := i) h)
+  | sort : RChildren P (.sort (ρ := ρ) (l := l) h)
+  | app : RChildren P (.app hf ha h)
+  | lam : RChildren P (.lam ha hdom hbody h)
+  | forallE : RChildren P (.forallE hb hb' hdom hbody h)
+  | const : (∀ m e hr, P (hR m e hr)) →
+      RChildren P (.const hreg hlen hle hty hA hC hR)
+
+/-- The complete propositional proof tree for a consumer that also follows
+ordinary syntax children.  At a constant, every abstract `R` edge carries a
+fresh copy of the consumer predicate as well as the tree below that edge.
+Ordinary children carry only the tree: a second, syntax-indexed induction is
+responsible for making progress there.
+
+This is deliberately stronger than `RChildren`.  The shallow predicate is
+the right interface for consumers whose current proof remains fixed;
+`RDeepChildren` supports lexicographic arguments that decrease either a
+syntax index along ordinary children or the semantic `R` tree at a constant.
+
+This remains proof-irrelevant provenance: it cannot distinguish constructor
+trees at equal public indices.  Derivation-sensitive evaluator recursion must
+instead choose an `LE_Interp.Witness` and use `Witness.recR`.
+-/
+inductive LE_Interp.RDeepChildren
+    (P : ∀ {ρ m M}, LE_Interp ρ m M → Prop) :
+    ∀ {ρ m M}, LE_Interp ρ m M → Prop where
+  | bot : RDeepChildren P (.bot (ρ := ρ) (M := M) (n := n))
+  | bvar : RDeepChildren P (.bvar (ρ := ρ) (i := i) h)
+  | sort : RDeepChildren P (.sort (ρ := ρ) (l := l) h)
+  | app : RDeepChildren P hf → RDeepChildren P ha →
+      RDeepChildren P (.app hf ha h)
+  | lam : RDeepChildren P ha →
+      (∀ x hx, RDeepChildren P (hbody x hx)) →
+      RDeepChildren P (.lam ha hdom hbody h)
+  | forallE : RDeepChildren P hb → RDeepChildren P hb' →
+      (∀ x hx, RDeepChildren P (hbody x hx)) →
+      RDeepChildren P (.forallE hb hb' hdom hbody h)
+  | const : RDeepChildren P hA →
+      (∀ m e hr, P (hR m e hr)) →
+      (∀ m e hr, RDeepChildren P (hR m e hr)) →
+      RDeepChildren P (.const hreg hlen hle hty hA hC hR)
+
+/-- Well-founded recursion along the semantic `R` edges visible in a
+propositional constant derivation.  The ordinary `LE_Interp` recursor proves
+accessibility because its constant minor already receives induction
+hypotheses for every `hR` child.
+
+The result must be invariant under proof choice.  No pattern or reduction
+evidence is manufactured here; a derivation-sensitive consumer should use
+`Witness.recR` and must still supply the proof-carrying contraction required
+by L4L-18B. -/
+theorem LE_Interp.recR
+    {P : ∀ {ρ m M}, LE_Interp ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp ρ m M), H.RChildren P → P H)
+    {rho m M} (H : LE_Interp rho m M) : P H := by
+  induction H with
+  | bot => exact step _ .bot
+  | bvar h => exact step _ (.bvar (h := h))
+  | sort h => exact step _ (.sort (h := h))
+  | app hf ha h _ _ => exact step _ (.app (hf := hf) (ha := ha) (h := h))
+  | lam ha hdom hbody h _ _ =>
+    exact step _ (.lam (ha := ha) (hdom := hdom) (hbody := hbody) (h := h))
+  | forallE hb hb' hdom hbody h _ _ _ =>
+    exact step _ (.forallE (hb := hb) (hb' := hb') (hdom := hdom)
+      (hbody := hbody) (h := h))
+  | const hreg hlen hle hty hA hC hR _ ihR =>
+    exact step _ (.const (hreg := hreg) (hlen := hlen) (hle := hle)
+      (hty := hty) (hA := hA) (hC := hC) (hR := hR) ihR)
+
+/-- Well-founded recursion through the complete propositional proof tree,
+while granting recursive calls only at abstract constant `R` edges.  Each
+`R` child simultaneously supplies both `P` and its tree.  This can be the
+semantic half of a lexicographic proof whose other half decreases an
+independent syntax/typing index along ordinary children, provided the result
+is insensitive to the proof chosen at fixed indices. -/
+theorem LE_Interp.recRDeep
+    {P : ∀ {ρ m M}, LE_Interp ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp ρ m M),
+      LE_Interp.RDeepChildren P H → P H)
+    {rho m M} (H : LE_Interp rho m M) : P H := by
+  suffices P H ∧ LE_Interp.RDeepChildren P H from this.1
+  induction H with
+  | bot => exact ⟨step _ .bot, .bot⟩
+  | bvar h => exact ⟨step _ (.bvar (h := h)), .bvar (h := h)⟩
+  | sort h => exact ⟨step _ (.sort (h := h)), .sort (h := h)⟩
+  | app hf ha h ihf iha =>
+    exact ⟨step _ (.app (h := h) ihf.2 iha.2),
+      .app (h := h) ihf.2 iha.2⟩
+  | lam ha hdom hbody h iha ihbody =>
+    exact ⟨step _ (.lam (hdom := hdom) (hbody := hbody) (h := h)
+        iha.2 (fun x hx => (ihbody x hx).2)),
+      .lam (hdom := hdom) (hbody := hbody) (h := h)
+        iha.2 (fun x hx => (ihbody x hx).2)⟩
+  | forallE hb hb' hdom hbody h ihb ihb' ihbody =>
+    exact ⟨step _ (.forallE (hdom := hdom) (hbody := hbody) (h := h)
+        ihb.2 ihb'.2 (fun x hx => (ihbody x hx).2)),
+      .forallE (hdom := hdom) (hbody := hbody) (h := h)
+        ihb.2 ihb'.2 (fun x hx => (ihbody x hx).2)⟩
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    exact ⟨step _ (.const (hreg := hreg) (hlen := hlen) (hle := hle)
+        (hty := hty) (hC := hC) ihA.2 (fun m e hr => (ihR m e hr).1)
+        (fun m e hr => (ihR m e hr).2)),
+      .const (hreg := hreg) (hlen := hlen) (hle := hle)
+        (hty := hty) (hC := hC) ihA.2 (fun m e hr => (ihR m e hr).1)
+        (fun m e hr => (ihR m e hr).2)⟩
+
+/-- Nested well-founded recursion over two propositional semantic trees.
+
+The first tree's recursive predicate is quantified over every possible
+second tree.  Consequently an abstract `R` edge on either side is a recursive
+call, while ordinary syntax children retain the tree needed by a second,
+syntax-indexed induction.  Proof irrelevance means this construction cannot
+retain an evaluator's exact constructor choice; it is therefore appropriate
+only for proof-independent binary predicates. -/
+theorem LE_Interp.recRDeep₂
+    {P : ∀ {ρm m M ρa a A},
+      LE_Interp ρm m M → LE_Interp ρa a A → Prop}
+    (step : ∀ {ρm m M ρa a A}
+        (hM : LE_Interp ρm m M) (hA : LE_Interp ρa a A),
+      LE_Interp.RDeepChildren
+          (fun hM' => ∀ {ρa a A} (hA' : LE_Interp ρa a A), P hM' hA') hM →
+      LE_Interp.RDeepChildren (fun hA' => P hM hA') hA →
+      P hM hA)
+    {rhom m M rhoa a A}
+    (hM : LE_Interp rhom m M) (hA : LE_Interp rhoa a A) :
+    P hM hA := by
+  refine LE_Interp.recRDeep
+    (P := fun hM =>
+      ∀ {rhoa a A} (hA : LE_Interp rhoa a A), P hM hA) ?_ hM hA
+  intro rhom m M hM childrenM rhoa a A hA
+  exact LE_Interp.recRDeep
+    (P := fun hA => P hM hA)
+    (fun hA childrenA => step hM hA childrenM childrenA) hA
+
 theorem LE_Interp.bvar' : LE_Interp ρ (ρ i) (.bvar i) := .bvar .rfl
 theorem LE_Interp.bvar0 : LE_Interp (.push ρ x) x (.bvar 0) := .bvar' (ρ := ρ.push x) (i := 0)
 theorem LE_Interp.sort' : LE_Interp ρ (.sort (l ≠ .zero)) (.sort l) := .sort .rfl
@@ -3394,6 +4869,199 @@ theorem LE_Interp.mono (h : m ≤ m') (H : LE_Interp ρ m' M) : LE_Interp ρ m M
   | forallE hb hb' hdom hbody h1 => exact .forallE hb hb' hdom hbody (h.trans h1)
   | const h1 h2 h3 h4 h5 h6 h7 => exact .const h1 h2 (h.trans h3) h4 h5 h6 h7
 
+/-- Realize a semantic RHS as the concrete S-expression obtained by
+instantiating its fixed leaves and materializing its captures.  Keeping this
+lemma separate from `RHS.mono` preserves the original `R` witness, which is
+what a proof-relevant fixed-head consumer uses before forgetting its chosen
+constructor tree. -/
+theorem LE_Interp.RHS.realize
+    (hR : ∀ {m M}, R m M → LE_Interp ρ m M)
+    (hcap : ∀ path, LE_Interp ρ (m2 path) (capture path))
+    (H : RHS ls m2 R m r) :
+    LE_Interp ρ m (r.applyS ls capture) := by
+  induction H with
+  | bot => exact .bot
+  | const hr => exact hR hr
+  | var hle => exact (hcap _).mono hle
+  | app _ _ hle ihf iha => exact .app ihf iha hle
+
+/-- Materialize a semantic RHS without forgetting the exact witness trees
+selected for its fixed leaves and captures.  The intermediate `Nonempty`
+result is the permitted elimination boundary from the propositional RHS
+derivation into the proof-relevant interpreter. -/
+theorem LE_Interp.RHS.realizeWitnessNonempty
+    {p : Pattern} {m2 : p.Path → TShape}
+    {capture : p.Path → SExpr} {r : p.RHS}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hcap : ∀ path, LE_Interp.Witness ρ (m2 path) (capture path))
+    (H : RHS ls m2 R m r) :
+    Nonempty (LE_Interp.Witness ρ m (r.applyS ls capture)) := by
+  induction H with
+  | bot => exact ⟨.bot⟩
+  | const hr => exact ⟨hR hr⟩
+  | var hle => exact ⟨(hcap _).mono hle⟩
+  | app _ _ hle ihf iha =>
+    exact ⟨.app (Classical.choice ihf) (Classical.choice iha) hle⟩
+
+/-- Choose the proof-relevant materialization of a complete semantic RHS. -/
+noncomputable def LE_Interp.RHS.realizeWitness
+    {p : Pattern} {m2 : p.Path → TShape}
+    {capture : p.Path → SExpr} {r : p.RHS}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hcap : ∀ path, LE_Interp.Witness ρ (m2 path) (capture path))
+    (H : RHS ls m2 R m r) :
+    LE_Interp.Witness ρ m (r.applyS ls capture) :=
+  Classical.choice (H.realizeWitnessNonempty hR hcap)
+
+theorem LE_Interp.RHS.realizeWitness_toInterp
+    {p : Pattern} {m2 : p.Path → TShape}
+    {capture : p.Path → SExpr} {r : p.RHS}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hcap : ∀ path, LE_Interp.Witness ρ (m2 path) (capture path))
+    (H : RHS ls m2 R m r) :
+    (H.realizeWitness hR hcap).toInterp =
+      H.realize (fun hr => (hR hr).toInterp)
+        (fun path => (hcap path).toInterp) :=
+  Subsingleton.elim _ _
+
+/-- A fixed semantic RHS selects either bottom or one exact recursive
+interpretation witness.  Returning `Nonempty` first is the permitted
+Prop-to-Type boundary; the relation parameter and its callback remain fixed
+even though the `RHS` derivation itself is proof-irrelevant. -/
+theorem LE_Interp.RHS.fixedWitnessNonempty
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : RHS ls m2 R m (.fixed e cl)) :
+    Nonempty (LE_Interp.Witness ρ m (SExpr.mkInst ls e)) := by
+  cases H with
+  | bot => exact ⟨.bot⟩
+  | const hr => exact ⟨hR hr⟩
+
+/-- Choose the exact witness selected by a fixed RHS. -/
+noncomputable def LE_Interp.RHS.fixedWitness
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : RHS ls m2 R m (.fixed e cl)) :
+    LE_Interp.Witness ρ m (SExpr.mkInst ls e) :=
+  Classical.choice (H.fixedWitnessNonempty hR)
+
+theorem LE_Interp.RHS.fixedWitness_toInterp
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : RHS ls m2 R m (.fixed e cl)) :
+    LE_Interp ρ m (SExpr.mkInst ls e) :=
+  (H.fixedWitness hR).toInterp
+
+/-- The downward-closed singleton relation generated by one exact witness.
+
+This is the focused evaluator relation used when reverse action soundness
+reconstructs a constant from a particular RHS endpoint.  Its only possible
+term is the endpoint retained by `hX`, and every realization is literally
+that witness with its root observation lowered.  Consequently the relation
+cannot broaden to an unrelated semantic derivation at the same public
+indices. -/
+def LE_Interp.Witness.LowerEdge
+    {ρ : Valuation} {root : TShape} {X : SExpr}
+    (hX : LE_Interp.Witness ρ root X)
+    (m : TShape) (M : SExpr) : Prop :=
+  M = X ∧ m ≤ root
+
+/-- Realize a focused edge without reselecting its proof-relevant tree. -/
+def LE_Interp.Witness.LowerEdge.realize
+    {hX : LE_Interp.Witness ρ root X}
+    (H : hX.LowerEdge m M) : LE_Interp.Witness ρ m M := by
+  obtain ⟨rfl, hle⟩ := H
+  exact hX.mono hle
+
+/-- Focused edges are closed under further root lowering. -/
+theorem LE_Interp.Witness.LowerEdge.mono
+    {hX : LE_Interp.Witness ρ root X}
+    (hle : m ≤ m') (H : hX.LowerEdge m' M) : hX.LowerEdge m M :=
+  ⟨H.1, hle.trans H.2⟩
+
+/-- The generating witness is the maximal focused edge. -/
+theorem LE_Interp.Witness.LowerEdge.self
+    (hX : LE_Interp.Witness ρ root X) : hX.LowerEdge root X :=
+  ⟨rfl, .rfl⟩
+
+/-- Downward closure of an abstract semantic relation.  Unlike mapping the
+relation into `LE_Interp`, this wrapper retains the original witness so that
+the matching proof-relevant callback remains recoverable at fixed RHS heads. -/
+def LE_Interp.Lower (R : TShape → SExpr → Prop) (m : TShape) (M : SExpr) : Prop :=
+  ∃ m', m ≤ m' ∧ R m' M
+
+theorem LE_Interp.Lower.of (H : R m M) : LE_Interp.Lower R m M :=
+  ⟨m, .rfl, H⟩
+
+theorem LE_Interp.Lower.mono
+    (h : m ≤ m') (H : LE_Interp.Lower R m' M) : LE_Interp.Lower R m M := by
+  obtain ⟨m'', hm', hR⟩ := H
+  exact ⟨m'', h.trans hm', hR⟩
+
+theorem LE_Interp.Lower.realize
+    (hR : ∀ {m M}, R m M → LE_Interp ρ m M)
+    (H : LE_Interp.Lower R m M) : LE_Interp ρ m M := by
+  obtain ⟨m', hm, hr⟩ := H
+  exact (hR hr).mono hm
+
+/-- Proof-relevant realization of downward closure.  The returned witness is
+the original `R` child with only its root observation lowered. -/
+noncomputable def LE_Interp.Lower.realizeWitness
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : LE_Interp.Lower R m M) : LE_Interp.Witness ρ m M := by
+  let m' := Classical.choose H
+  have hm : m ≤ m' := (Classical.choose_spec H).1
+  have hr : R m' M := (Classical.choose_spec H).2
+  exact (hR hr).mono hm
+
+/-- Realize the fixed head selected by a downward-closed evaluator branch
+through the exact recursive witness callback of its enclosing constant. -/
+noncomputable def LE_Interp.RHS.fixedLowerWitness
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : RHS ls m2 (LE_Interp.Lower R) m (.fixed e cl)) :
+    LE_Interp.Witness ρ m (SExpr.mkInst ls e) :=
+  H.fixedWitness (LE_Interp.Lower.realizeWitness hR)
+
+/-- Select a non-bottom fixed head together with the recursive result carried
+by the exact `R` edge that produced it.  The ordinary `fixedLowerWitness`
+adapter intentionally forgets this second component; adequacy cannot do so,
+because choosing another witness at the same public indices may choose a
+different abstract constant relation.
+
+The monotonicity callback accounts for `Lower`: the evaluator may expose an
+`R` witness at a larger observation and then lower only its root. -/
+theorem LE_Interp.RHS.fixedLowerWitnessResultNonempty
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hP : ∀ {m M} (hr : R m M), P (hR hr))
+    (hmono : ∀ {m m' M} (hle : m ≤ m')
+      (H : LE_Interp.Witness ρ m' M), P H → P (H.mono hle))
+    (H : RHS ls m2 (LE_Interp.Lower R) m (.fixed e cl))
+    (hnonbot : ¬m ≤ TShape.bot) :
+    Nonempty {H : LE_Interp.Witness ρ m (SExpr.mkInst ls e) // P H} := by
+  cases H with
+  | bot => exact (hnonbot TShape.bot_eqv.1).elim
+  | const hr =>
+    obtain ⟨m', hle, hr⟩ := hr
+    exact ⟨⟨(hR hr).mono hle, hmono hle (hR hr) (hP hr)⟩⟩
+
+/-- The proof-relevant fixed-head package selected by
+`fixedLowerWitnessResultNonempty`. -/
+noncomputable def LE_Interp.RHS.fixedLowerWitnessResult
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hP : ∀ {m M} (hr : R m M), P (hR hr))
+    (hmono : ∀ {m m' M} (hle : m ≤ m')
+      (H : LE_Interp.Witness ρ m' M), P H → P (H.mono hle))
+    (H : RHS ls m2 (LE_Interp.Lower R) m (.fixed e cl))
+    (hnonbot : ¬m ≤ TShape.bot) :
+    {H : LE_Interp.Witness ρ m (SExpr.mkInst ls e) // P H} :=
+  Classical.choice
+    (H.fixedLowerWitnessResultNonempty hR hP hmono hnonbot)
+
+theorem LE_Interp.RHS.fixedLowerWitness_toInterp
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : RHS ls m2 (LE_Interp.Lower R) m (.fixed e cl)) :
+    LE_Interp ρ m (SExpr.mkInst ls e) :=
+  (H.fixedLowerWitness hR).toInterp
+
 theorem LE_Interp.mono_l (hρ : ρ.LE ρ') (H : LE_Interp ρ m M) : LE_Interp ρ' m M := by
   induction H generalizing ρ' with
   | bot => exact .bot
@@ -3429,6 +5097,28 @@ theorem LE_Interp.Matches.arity (H : Matches p c rargs m) : Arity (.const c) rar
   | var _ ih => exact .var ih
   | app _ _ ih_f _ => exact .app ih_f
 
+theorem LE_Interp.Matches.nil_inv
+    (H : Matches (n := n) p c [] m) : p = .const c := by
+  cases H
+  rfl
+
+/-- A reached nonempty pattern spine is necessarily an iota pattern.
+Definition patterns match only the bare constant, so they cannot occur after
+the constant evaluator has consumed its first related argument. -/
+theorem LE_Interp.Matches.iota_of_pat_nonempty
+    (hpat : Params.Pat p r) (H : Matches (n := n) p c rargs m)
+    (hne : rargs ≠ []) :
+    ∃ rec major ctor arity,
+      p = RecursorIotaPattern rec major ctor arity := by
+  obtain ⟨sp, hp⟩ := Params.pat_simple hpat
+  cases sp with
+  | defn head =>
+    subst p
+    cases H
+    exact (hne rfl).elim
+  | iota rec major ctor arity =>
+    exact ⟨rec, major, ctor, arity, hp⟩
+
 theorem LE_Interp.Matches.head_wf (H : Matches p c rargs m) (wf : p.WF cl top k) :
     ∃ k, cl c = some (if top then .symb k else .ctor k) := by
   induction H generalizing k with
@@ -3476,6 +5166,27 @@ theorem LE_Interp.Const.mono_l (h : rargs.Forall₂ (· ≤ ·) rargs')
     have ⟨_, a1, a2⟩ := h2.mono_l (Params.pat_wf h1) h
     refine .pat h1 a1 (h3.mono_l a2)
 
+theorem LE_Interp.Const.lam_apply
+    {g f : WShapeFun n} {hg : g.NonZero}
+    (hrec : ∀ x y : WShape n, (x, y) ∈ f →
+      Const c ls R (x :: rargs) y.T)
+    (hle : (WShape.lam g hg).T ≤ (WShape.lam' f).T)
+    (hR : ∀ {a a' A}, a ≤ a' → R a' A → R a A)
+    (p : WShape n) :
+    Const c ls R (p :: rargs) (g.app p).T := by
+  have hgf : g ≤ f := by
+    have hle' : (WShape.lam' g).T ≤ (WShape.lam' f).T := by
+      rw [← WShape.lam_eq_lam' (f := g) (hl := hg)]
+      exact hle
+    have hgf := TShape.LE.lam'_decomp hle'
+    exact (WShapeFun.lift_le_lift (Nat.le_max_left n n)).1 hgf
+  obtain ⟨x₀, hx₀, hmemg⟩ := g.app_eq p
+  obtain ⟨x, y, hmemf, hx, hy⟩ := WShapeFun.LE.def'.1 hgf _ _ hmemg
+  have hc : Const c ls R (x :: rargs) (g.app p).T :=
+    LE_Interp.Const.mono (c := c) (ls := ls) (R := R) (R' := R)
+      hy.T (fun le hr => hR le hr) (hrec x y hmemf)
+  exact hc.mono_l (.cons (hx.trans hx₀) (.rfl fun _ _ => .rfl))
+
 theorem LE_Interp.Matches.matches_inter {rargs rargs'}
     (hc : List.Forall₂ WShape.Compat rargs rargs')
     (hp : Matches (n := n) p c rargs m) (wfp : p.WF Params.classify b k)
@@ -3617,6 +5328,89 @@ theorem pat_arity (hP : Params.Pat p r) (h : Arity (.const c) n p) :
   | var _ ih => simpa [Nat.succ_add, ← Nat.add_assoc] using ih _ h1
   | app _ ih => simpa [Nat.succ_add, ← Nat.add_assoc] using ih _ h1.1
 
+theorem const_spine_ne_lam
+    {c : Name} {ls : List SLevel} {args : List SExpr} {A e : SExpr} :
+    args.foldr (fun (a f : SExpr) => .app f a) (.const c ls) ≠ .lam A e := by
+  induction args with
+  | nil => simp
+  | cons => simp
+
+private def constHead? : SExpr → Option Name
+  | .const c _ => some c
+  | .app f _ => constHead? f
+  | _ => none
+
+@[simp] private theorem constHead?_spine
+    {c : Name} {ls : List SLevel} {args : List SExpr} :
+    constHead? (args.foldr (fun a f => f.app a) (.const c ls)) = some c := by
+  induction args with
+  | nil => rfl
+  | cons _ _ ih => exact ih
+
+/-- A constant-headed spine whose head is not a rewrite symbol cannot be
+selected by the user reduction-pattern system. -/
+theorem WHNF.const_spine
+    {c : Name} {ls : List SLevel} {args : List SExpr}
+    (hcl : ∀ k, Params.classify c ≠ some (.symb k)) :
+    WHNF Γ (args.foldr (fun a f => f.app a) (.const c ls)) := by
+  induction args with
+  | nil =>
+    intro e hred
+    cases hred with
+    | extra action =>
+      obtain ⟨c', ls', as, heq, har⟩ := action.matched.head_spine
+      simp only [List.foldr_nil] at heq
+      have hc : c = c' := by
+        simpa only [constHead?, constHead?_spine, Option.some.injEq] using
+          congrArg constHead? heq
+      subst c'
+      exact hcl _ (pat_arity action.pat har)
+  | cons a args ih =>
+    simp only [List.foldr_cons]
+    intro e hred
+    generalize hf : args.foldr (fun (a f : SExpr) => .app f a) (.const c ls) = f at hred
+    cases hred with
+    | app h =>
+      rw [← hf] at h
+      exact ih _ h
+    | major hmajor _ =>
+      obtain ⟨p, ⟨r, hp⟩, p₁, p₂, hsub, m1, m2, hm⟩ := hmajor
+      cases Params.simple_appS hp hsub
+      obtain ⟨c', ls', as, heq, har⟩ := hm.head_spine
+      rw [← hf] at heq
+      have hc : c = c' := by
+        simpa only [constHead?, constHead?_spine, Option.some.injEq] using
+          congrArg constHead? heq
+      subst c'
+      exact hcl _ (pat_arity hp (.app har))
+    | beta => exact const_spine_ne_lam hf
+    | extra action =>
+      obtain ⟨c', ls', as, heq, har⟩ := action.matched.head_spine
+      rw [← hf] at heq
+      have hc : c = c' := by
+        simpa only [constHead?, constHead?_spine, Option.some.injEq] using
+          congrArg constHead? heq
+      subst c'
+      exact hcl _ (pat_arity action.pat har)
+
+/-- Inductive-type heads are weak-head normal. -/
+theorem WHNF.indTy_spine
+    {c : Name} {ls : List SLevel} {args : List SExpr} {k : Nat}
+    (hcl : Params.classify c = some (.indTy k)) :
+    WHNF Γ (args.foldr (fun a f => f.app a) (.const c ls)) :=
+  .const_spine fun _ hs => by
+    have hbad : (.indTy k : Classification) = .symb _ := Option.some.inj (hcl.symm.trans hs)
+    cases hbad
+
+/-- Fully applied ordinary constructor heads are weak-head normal. -/
+theorem WHNF.ctor_spine
+    {c : Name} {ls : List SLevel} {args : List SExpr} {k : Nat}
+    (hcl : Params.classify c = some (.ctor k)) :
+    WHNF Γ (args.foldr (fun a f => f.app a) (.const c ls)) :=
+  .const_spine fun _ hs => by
+    have hbad : (.ctor k : Classification) = .symb _ := Option.some.inj (hcl.symm.trans hs)
+    cases hbad
+
 theorem LE_Interp.Matches.lift (le : n ≤ n') (H : Matches (n := n) p c rargs m) :
     ∃ m', Matches p c (rargs.map (.lift n')) m' ∧ ∀ p, m p ≤ m' p ∧ m' p ≤ m p := by
   induction H generalizing n' with
@@ -3631,6 +5425,188 @@ theorem LE_Interp.Matches.lift (le : n ≤ n') (H : Matches (n := n) p c rargs m
     rw [WShape.lift_ctor' (Nat.le_of_succ_le_succ le), List.map_reverse]
     exact f1.app a1
 
+/-- Reflect an ordinary-constructor observation through an exact lift.
+
+The classification premise rules out the structure-constructor bottom case,
+so a lifted constructor head has a genuine constructor predecessor and its
+fields are exact lifts of the predecessor fields. -/
+theorem WShape.lift_eq_ctor'_of_classify_ctor
+    {c : Name} {arity : Nat}
+    {s : WShape (n + 1)} {l : List (WShape m)}
+    (le : n ≤ m)
+    (hcl : Params.classify c = some (.ctor arity))
+    (eq : s.lift (m + 1) = .ctor' c l) :
+    ∃ l0 : List (WShape n),
+      s = .ctor' c l0 ∧ l = l0.map (fun x => x.lift m) := by
+  have hns : ¬ IsStruct c := by
+    simp [IsStruct, hcl]
+  have htarget : IsStruct c → WShape.ListNonZero l :=
+    fun hs => (hns hs).elim
+  rw [WShape.ctor', dif_pos htarget] at eq
+  cases s using WShape.casesOn' with
+  | bot =>
+    simp only [WShape.lift_bot] at eq
+    simp [WShape.ext_iff, WShape.bot, WShape.ctor, Shape.bot] at eq
+  | sort r =>
+    simp only [WShape.lift_sort] at eq
+    simp [WShape.ext_iff, WShape.sort, WShape.ctor, Shape.sort] at eq
+  | forallE a f =>
+    rw [WShape.lift_forallE le] at eq
+    simp [WShape.ext_iff, WShape.forallE, WShape.ctor] at eq
+  | lam f hf =>
+    rw [WShape.lift_lam le] at eq
+    simp [WShape.ext_iff, WShape.lam, WShape.ctor] at eq
+  | ctor c0 l0 h0 =>
+    rw [WShape.lift_ctor le] at eq
+    obtain ⟨rfl, hl⟩ := WShape.ctor.inj.1 eq
+    exact ⟨l0, (WShape.ctor_eq_ctor' (h := h0)), hl.symm⟩
+  | indTy =>
+    rw [WShape.lift_indTy] at eq
+    simp [WShape.ext_iff, WShape.indTy, WShape.ctor] at eq
+
+private theorem LE_Interp.Matches.unlift_aux
+    {p : Pattern} {c : Name} {n n' : Nat}
+    {rs : List (WShape n')} {rargs : List (WShape n)}
+    {m : p.Path → TShape}
+    (le : n ≤ n')
+    (wf : p.WF Params.classify b k)
+    (H : Matches (n := n') p c rs m)
+    (heq : rs = rargs.map (fun x => x.lift n')) :
+    ∃ m0, Matches (n := n) p c rargs m0 := by
+  induction H generalizing n rargs b k with
+  | const =>
+    cases rargs with
+    | nil => exact ⟨_, .const⟩
+    | cons a rargs => simp at heq
+  | @var f c n' rargs' mf a H ih =>
+    cases rargs with
+    | nil => simp at heq
+    | cons a0 rargs0 =>
+      simp only [List.map_cons, List.cons.injEq] at heq
+      obtain ⟨_ha, htail⟩ := heq
+      obtain ⟨m0, hm0⟩ := ih le wf htail
+      exact ⟨_, hm0.var⟩
+  | @app fPat nHigh head rargsHigh mf aPat c' rargsArg ma hf ha ihf iha =>
+    cases rargs with
+    | nil => simp at heq
+    | cons head0 tail0 =>
+      simp only [List.map_cons, List.cons.injEq] at heq
+      obtain ⟨hhead, htail⟩ := heq
+      obtain ⟨arity, hcl⟩ := ha.head_wf wf.2
+      simp only [Bool.false_eq_true, if_false] at hcl
+      cases n with
+      | zero =>
+        have htarget : IsStruct c' → WShape.ListNonZero rargsArg.reverse := by
+          intro hs
+          simp [IsStruct, hcl] at hs
+        have hctorNeBot :
+            WShape.ctor c' rargsArg.reverse htarget ≠
+              (WShape.bot : WShape (nHigh + 1)) := by
+          intro h
+          have h' := congrArg (fun x => x.1) h
+          simp [WShape.ctor, WShape.bot, Shape.bot] at h'
+        rw [WShape.ctor', dif_pos htarget] at hhead
+        cases head0 using WShape.casesOn with
+        | bot =>
+          change WShape.ctor c' rargsArg.reverse htarget =
+            (WShape.bot : WShape 0).lift (nHigh + 1) at hhead
+          rw [WShape.lift_bot] at hhead
+          exact (hctorNeBot hhead).elim
+        | sort r0 =>
+          change WShape.ctor c' rargsArg.reverse htarget =
+            (WShape.sort r0 : WShape 0).lift (nHigh + 1) at hhead
+          rw [WShape.lift_sort] at hhead
+          have hbad : (WShape.sort r0 : WShape (nHigh + 1)).T ≤
+              (WShape.ctor c' rargsArg.reverse htarget).T := by
+            exact WShape.LE.T (by rw [hhead]; exact .rfl)
+          have hbad' : (WShape.sort r0 : WShape (nHigh + 1)).T ≤
+              (WShape.ctor' c' rargsArg.reverse).T := by
+            rw [WShape.ctor', dif_pos htarget]
+            exact hbad
+          exact (TShape.sort_not_le_ctor'
+            (r := r0) (c := c') (l := rargsArg.reverse) hbad').elim
+      | succ nLow =>
+        have lePred : nLow ≤ nHigh := Nat.le_of_succ_le_succ le
+        obtain ⟨fields0, hhead0, hfields⟩ :=
+          WShape.lift_eq_ctor'_of_classify_ctor lePred hcl hhead.symm
+        have hfields' : rargsArg =
+            fields0.reverse.map (fun x => x.lift nHigh) := by
+          have h := congrArg List.reverse hfields
+          simpa only [List.reverse_reverse, List.map_reverse] using h
+        obtain ⟨mf0, hmf0⟩ := ihf le wf.1 htail
+        obtain ⟨ma0, hma0⟩ := iha lePred wf.2 hfields'
+        subst head0
+        exact ⟨_, by
+          simpa only [List.reverse_reverse] using hmf0.app hma0⟩
+
+/-- Reflect a semantic pattern match from exact lifted arguments. -/
+theorem LE_Interp.Matches.unlift
+    {p : Pattern} {c : Name} {n n' : Nat}
+    {rargs : List (WShape n)}
+    {m : p.Path → TShape}
+    (le : n ≤ n')
+    (wf : p.WF Params.classify b k)
+    (H : Matches (n := n') p c
+      (rargs.map (fun x => x.lift n')) m) :
+    ∃ m0, Matches (n := n) p c rargs m0 ∧
+      ∀ path, m path ≤ m0 path ∧ m0 path ≤ m path := by
+  obtain ⟨m0, hm0⟩ := LE_Interp.Matches.unlift_aux le wf H rfl
+  obtain ⟨mLift, hmLift, hcap⟩ := hm0.lift le
+  have heq : m = mLift := H.unique wf hmLift
+  subst mLift
+  exact ⟨m0, hm0, fun path => ⟨(hcap path).2, (hcap path).1⟩⟩
+
+/-- Lift a heterogeneous list of `TShape` bounds to one common concrete
+shape level. -/
+theorem WShape.forall₂_liftT
+    {xs : List (WShape n)} {ys : List (WShape n')}
+    (hn : n ≤ K) (hn' : n' ≤ K)
+    (H : List.Forall₂ (fun x y => x.T ≤ y.T) xs ys) :
+    List.Forall₂ (· ≤ ·)
+      (xs.map (fun x => x.lift K))
+      (ys.map (fun y => y.lift K)) := by
+  induction H with
+  | nil => exact .nil
+  | cons hxy hrest ih =>
+    exact .cons ((TShape.LE.def hn hn').1 hxy) ih
+
+/-- Lift only the target of a heterogeneous list bound. -/
+theorem WShape.forall₂_liftT_right
+    {xs : List (WShape n)} {ys : List (WShape n')}
+    (hn' : n' ≤ K)
+    (H : List.Forall₂ (fun x y => x.T ≤ y.T) xs ys) :
+    List.Forall₂ (fun x y => x.T ≤ y.T)
+      xs (ys.map (fun y => y.lift K)) := by
+  induction H with
+  | nil => exact .nil
+  | cons hxy hrest ih =>
+    exact .cons (hxy.trans (TShape.lift_eqv hn').2) ih
+
+/-- Enlarge a semantic match across unrelated concrete shape depths.
+
+Only the level-free `TShape` bounds are semantically relevant.  Both sides
+are lifted to a temporary common level, the ordinary monotonicity theorem is
+applied there, and exact-lift reflection returns to the target level. -/
+theorem LE_Interp.Matches.mono_lT
+    {p : Pattern} {c : Name} {n n' : Nat}
+    {rargs : List (WShape n)} {rargs' : List (WShape n')}
+    {m : p.Path → TShape}
+    (wf : p.WF Params.classify b k)
+    (hc : List.Forall₂ (fun x y => x.T ≤ y.T) rargs rargs')
+    (H : Matches (n := n) p c rargs m) :
+    ∃ m', Matches (n := n') p c rargs' m' ∧
+      ∀ path, m path ≤ m' path := by
+  let K := max n n'
+  have hn : n ≤ K := Nat.le_max_left ..
+  have hn' : n' ≤ K := Nat.le_max_right ..
+  obtain ⟨mK, hmK, hcapK⟩ := H.lift hn
+  have hcK := WShape.forall₂_liftT hn hn' hc
+  obtain ⟨mK', hmK', hcapK'⟩ := hmK.mono_l wf hcK
+  obtain ⟨m', hm', hcap'⟩ := hmK'.unlift hn' wf
+  refine ⟨m', hm', fun path => ?_⟩
+  exact (hcapK path).1 |>.trans <|
+    (hcapK' path).trans (hcap' path).1
+
 theorem LE_Interp.Const.lift (hn : n₁ ≤ n₂)
     (hR : ∀ {a a' A}, a ≤ a' → R a' A → R a A)
     (H : Const (n := n₁) c ls R rargs m) : Const c ls R (rargs.map (.lift n₂)) m := by
@@ -3660,7 +5636,7 @@ theorem LE_Interp.RHS.closed
     (H : RHS m1 m2 R m r) : RHS m1 m2 (fun e A => A.ClosedN ∧ R e A) m r := by
   induction H with
   | bot => exact .bot
-  | @const _ _ cl h1 => exact .const ⟨cl.mkS.instL, h1⟩
+  | @const _ _ cl h1 => exact .const ⟨cl.mkInstS, h1⟩
   | var h1 => exact .var h1
   | app hf ha h1 ih_f ih_a => exact .app ih_f ih_a h1
 
@@ -3689,13 +5665,358 @@ theorem LE_Interp.closed (cl : ClosedN M k) (h : ∀ i < k, ρ i = ρ' i)
     intro | 0, _ => rfl | i+1, hi => exact h i (Nat.lt_of_succ_lt_succ hi)
   | const h1 h2 h3 h4 _ h6 _ ih1 ih2 =>
     refine .const h1 h2 h3 h4 (ih1 ?_ h) h6.closed fun m e ⟨a1, a2⟩ => ?_
-    · exact (Params.henv.closedC h1).mkS.instL.mono (Nat.zero_le _)
+    · exact (Params.henv.closedC h1).mkInstS.mono (Nat.zero_le _)
     · exact ih2 m e a2 (a1.mono (Nat.zero_le _)) h
 
 theorem LE_Interp.closed_iff {M : SExpr} (cl : ClosedN M)
     {ρ ρ' : Valuation} {m : TShape} : LE_Interp ρ m M ↔ LE_Interp ρ' m M :=
   ⟨closed cl nofun, closed cl nofun⟩
 
+/-- Change the valuation of a closed expression without discarding its
+chosen constructor tree or recursive constant callbacks.  This internal
+transport is noncomputable because the constant case uses the propositional
+closure certificate returned by `Const.closed`. -/
+noncomputable def LE_Interp.Witness.closed (cl : ClosedN M k)
+    (hρ : ∀ i < k, ρ i = ρ' i)
+    (H : LE_Interp.Witness ρ m M) : LE_Interp.Witness ρ' m M := by
+  induction H generalizing k ρ' with
+  | bot => exact .bot
+  | sort hle => exact .sort hle
+  | bvar hle => exact .bvar ((hρ _ cl).symm ▸ hle)
+  | app hf ha hle ihf iha =>
+    exact .app (ihf cl.1 hρ) (iha cl.2 hρ) hle
+  | lam ha hdom hbody hle iha ihbody =>
+    refine .lam (iha cl.1 hρ) hdom (fun x hx => ihbody x hx cl.2 ?_) hle
+    intro i hi
+    cases i with
+    | zero => rfl
+    | succ i => exact hρ i (Nat.lt_of_succ_lt_succ hi)
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    refine .forallE (ihb cl.1 hρ) (ihb' cl.1 hρ) hdom
+      (fun x hx => ihbody x hx cl.2 ?_) hle
+    intro i hi
+    cases i with
+    | zero => rfl
+    | succ i => exact hρ i (Nat.lt_of_succ_lt_succ hi)
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    refine .const hreg hlen hle hty
+      (ihA ((Params.henv.closedC hreg).mkInstS.mono (Nat.zero_le _)) hρ)
+      hC.closed (fun m e hr => ?_)
+    exact ihR m e hr.2 hr.1 nofun
+
+/-- A closed witness is independent of its valuation. -/
+noncomputable def LE_Interp.Witness.closedAt {M : SExpr} (cl : ClosedN M)
+    (H : LE_Interp.Witness ρ m M) : LE_Interp.Witness ρ' m M :=
+  H.closed cl nofun
+
+theorem LE_Interp.Witness.closed_toInterp
+    {ρ ρ' : Valuation} {m : TShape} {M : SExpr} {k : Nat}
+    (cl : ClosedN M k)
+    (hρ : ∀ i < k, ρ i = ρ' i)
+    (H : LE_Interp.Witness ρ m M) :
+    (H.closed cl hρ).toInterp = H.toInterp.closed cl hρ :=
+  Subsingleton.elim _ _
+
+/-- Change the valuation throughout a retained recursion tree for a closed
+expression.  Constant callbacks acquire the closure certificate stored by
+`Const.closed`; the recursive-result transport is consequently passed that
+same certificate, ensuring it follows the exact transformed callback rather
+than a freshly chosen interpretation. -/
+theorem LE_Interp.Witness.RDeepChildren.closed
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' : Valuation} {m : TShape} {M : SExpr} {k : Nat}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {ρ ρ' : Valuation} {m : TShape} {M : SExpr} {k : Nat}
+    {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P)
+    (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i) :
+    (H.closed cl hρ).RDeepChildren P := by
+  induction H generalizing k ρ' with
+  | @bot ρ n M =>
+    cases children
+    cases M <;> exact .bot
+  | sort hle =>
+    cases children
+    exact .sort
+  | bvar hle =>
+    cases children
+    exact .bvar
+  | app hf ha hle ihf iha =>
+    cases children with
+    | app cf ca => exact .app (ihf cf cl.1 hρ) (iha ca cl.2 hρ)
+  | lam ha hdom hbody hle iha ihbody =>
+    cases children with
+    | lam ca cbody =>
+      exact .lam (iha ca cl.1 hρ) (fun x hx =>
+        ihbody x hx (cbody x hx) cl.2 (fun i hi => by
+          cases i with
+          | zero => rfl
+          | succ i => exact hρ i (Nat.lt_of_succ_lt_succ hi)))
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    cases children with
+    | forallE cb cb' cbody =>
+      exact .forallE (ihb cb cl.1 hρ) (ihb' cb' cl.1 hρ)
+        (fun x hx => ihbody x hx (cbody x hx) cl.2 (fun i hi => by
+          cases i with
+          | zero => rfl
+          | succ i => exact hρ i (Nat.lt_of_succ_lt_succ hi)))
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    cases children with
+    | const cA pR cR =>
+      exact .const
+        (ihA cA ((Params.henv.closedC hreg).mkInstS.mono
+          (Nat.zero_le _)) hρ)
+        (fun m e hr => hP (hR m e hr.2) hr.1 nofun (pR m e hr.2))
+        (fun m e hr => ihR m e hr.2 (cR m e hr.2) hr.1 nofun)
+
+/-- Remove one syntactic lift from a proof-relevant interpretation while
+retaining its exact constructor tree.  The valuation equation is the same
+one used by `LE_Interp.weak'_iff`; the constant case keeps the underlying
+recursive callback and merely records the closed syntax wrapper introduced
+by transport. -/
+noncomputable def LE_Interp.Witness.unlift'
+    (l : Lift) (hρ : ∀ i, ρ i = ρ' (l.liftVar i))
+    (H : LE_Interp.Witness ρ' m (M.lift' l)) :
+    LE_Interp.Witness ρ m M := by
+  generalize eq : M.lift' l = M' at H
+  induction H generalizing M ρ l with first
+    | subst eq | cases M <;> cases eq
+  | bot => exact .bot
+  | sort hle => exact .sort hle
+  | bvar hle => exact .bvar (hρ _ ▸ hle)
+  | app hf ha hle ihf iha =>
+    exact .app (ihf _ hρ rfl) (iha _ hρ rfl) hle
+  | lam ha hdom hbody hle iha ihbody =>
+    refine .lam (iha _ hρ rfl) hdom (fun y hy => ?_) hle
+    exact ihbody y hy _
+      (fun i => by cases i <;> simp [Valuation.push, hρ]) rfl
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    refine .forallE (ihb _ hρ rfl) (ihb' _ hρ rfl) hdom
+      (fun y hy => ?_) hle
+    exact ihbody y hy _
+      (fun i => by cases i <;> simp [Valuation.push, hρ]) rfl
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    refine .const hreg hlen hle hty ?_ hC.closed ?_
+    · exact ihA _ hρ <| (Params.henv.closedC hreg).mkInstS.lift'_eq .zero
+    · rintro m A ⟨hclosed, hr⟩
+      exact ihR _ _ hr _ hρ <| hclosed.lift'_eq .zero
+
+/-- Add a syntactic lift to a proof-relevant interpretation without choosing
+a fresh propositional derivation. -/
+noncomputable def LE_Interp.Witness.lift'
+    (l : Lift) (hρ : ∀ i, ρ i = ρ' (l.liftVar i))
+    (H : LE_Interp.Witness ρ m M) :
+    LE_Interp.Witness ρ' m (M.lift' l) := by
+  induction H generalizing ρ' l with
+  | bot => exact .bot
+  | sort hle => exact .sort hle
+  | bvar hle => exact .bvar (hρ _ ▸ hle)
+  | app hf ha hle ihf iha =>
+    exact .app (ihf l hρ) (iha l hρ) hle
+  | lam ha hdom hbody hle iha ihbody =>
+    refine .lam (iha l hρ) hdom (fun y hy => ?_) hle
+    exact ihbody y hy l.cons fun i => by
+      cases i <;> simp [Valuation.push, hρ]
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    refine .forallE (ihb l hρ) (ihb' l hρ) hdom (fun y hy => ?_) hle
+    exact ihbody y hy l.cons fun i => by
+      cases i <;> simp [Valuation.push, hρ]
+  | const hreg hlen hle hty hA hC hR _ _ =>
+    refine .const hreg hlen hle hty
+      (hA.closedAt (Params.henv.closedC hreg).mkInstS)
+      hC.closed (fun m A hr => ?_)
+    exact (hR m A hr.2).closedAt hr.1
+
+/-- Syntactic lifting preserves a retained recursion tree.  Registered
+constant children are closed, so their exact callbacks change valuation via
+`Witness.closed`; the caller supplies precisely that recursive-result
+transport and no proof-irrelevant witness is reselected. -/
+theorem LE_Interp.Witness.RDeepChildren.lift'
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {ρ ρ' : Valuation} {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P)
+    (l : Lift) (hρ : ∀ i, ρ i = ρ' (l.liftVar i)) :
+    (H.lift' l hρ).RDeepChildren P := by
+  induction H generalizing ρ' l with
+  | bot =>
+    cases children
+    exact .bot
+  | bvar hle =>
+    cases children
+    exact .bvar
+  | sort hle =>
+    cases children
+    exact .sort
+  | app hf ha hle ihf iha =>
+    cases children with
+    | app cf ca => exact .app (ihf cf l hρ) (iha ca l hρ)
+  | lam ha hdom hbody hle iha ihbody =>
+    cases children with
+    | lam ca cbody =>
+      exact .lam (iha ca l hρ) (fun x hx =>
+        ihbody x hx (cbody x hx) l.cons (fun i => by
+          cases i <;> simp [Valuation.push, hρ]))
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    cases children with
+    | forallE cb cb' cbody =>
+      exact .forallE (ihb cb l hρ) (ihb' cb' l hρ)
+        (fun x hx => ihbody x hx (cbody x hx) l.cons (fun i => by
+          cases i <;> simp [Valuation.push, hρ]))
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    cases children with
+    | const cA pR cR =>
+      exact .const
+        (cA.closed hP (Params.henv.closedC hreg).mkInstS nofun)
+        (fun m e hr => hP (hR m e hr.2) hr.1 nofun (pR m e hr.2))
+        (fun m e hr => (cR m e hr.2).closed hP hr.1 nofun)
+
+/-- Remove the standard one-variable weakening from a witness. -/
+noncomputable def LE_Interp.Witness.unweak
+    (H : LE_Interp.Witness (ρ.push x) m M.lift) :
+    LE_Interp.Witness ρ m M :=
+  H.unlift' (.skip .refl) (fun _ => rfl)
+
+/-- Weaken a witness by one variable while preserving its recursive
+provenance. -/
+noncomputable def LE_Interp.Witness.weak
+    (H : LE_Interp.Witness ρ m M) :
+    LE_Interp.Witness (ρ.push x) m M.lift :=
+  H.lift' (.skip .refl) (fun _ => rfl)
+
+/-- Standard one-variable weakening preserves every exact recursive
+callback. -/
+theorem LE_Interp.Witness.RDeepChildren.weak
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P) :
+    (H.weak (x := x)).RDeepChildren P := by
+  exact children.lift' hP (.skip .refl) (fun _ => rfl)
+
+/-- Substitute a proof-relevant interpretation forward while retaining the
+exact constructor choices and recursive constant callbacks.  Under a binder,
+the substitution witnesses are weakened in lockstep with `Subst.lift`. -/
+noncomputable def LE_Interp.Witness.subst
+    (H : LE_Interp.Witness ρ' m M)
+    (hσ : ∀ i, LE_Interp.Witness ρ (ρ' i) (σ i)) :
+    LE_Interp.Witness ρ m (M.subst σ) := by
+  induction H generalizing ρ σ with
+  | bot => exact .bot
+  | bvar hle => exact (hσ _).mono hle
+  | sort hle => exact .sort hle
+  | app hf ha hle ihf iha =>
+    exact .app (ihf hσ) (iha hσ) hle
+  | lam ha hdom hbody hle iha ihbody =>
+    refine .lam (iha hσ) hdom (fun x hx => ?_) hle
+    exact ihbody x hx fun
+      | 0 => .bvar .rfl
+      | i + 1 => (hσ i).weak
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    refine .forallE (ihb hσ) (ihb' hσ) hdom (fun x hx => ?_) hle
+    exact ihbody x hx fun
+      | 0 => .bvar .rfl
+      | i + 1 => (hσ i).weak
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    refine .const hreg hlen hle hty
+      (hA.closedAt (Params.henv.closedC hreg).mkInstS)
+      hC.closed (fun m e hr => ?_)
+    exact (hR m e hr.2).closedAt hr.1
+
+/-- Substitute exact witnesses throughout a retained recursion tree.
+Variable nodes reuse the supplied tree, while registered constant callbacks
+use their evaluator-provided closure certificate. -/
+theorem LE_Interp.Witness.RDeepChildren.subst
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {ρ ρ' : Valuation} {σ : Subst}
+    {H : LE_Interp.Witness ρ' m M}
+    (children : H.RDeepChildren P)
+    (hσ : ∀ i, LE_Interp.Witness ρ (ρ' i) (σ i))
+    (cσ : ∀ i, (hσ i).RDeepChildren P) :
+    (H.subst hσ).RDeepChildren P := by
+  induction H generalizing ρ σ with
+  | bot =>
+    cases children
+    exact .bot
+  | bvar hle =>
+    cases children
+    exact (cσ _).mono hle
+  | sort hle =>
+    cases children
+    exact .sort
+  | app hf ha hle ihf iha =>
+    cases children with
+    | app cf ca => exact .app (ihf cf hσ cσ) (iha ca hσ cσ)
+  | lam ha hdom hbody hle iha ihbody =>
+    cases children with
+    | lam ca cbody =>
+      refine .lam (iha ca hσ cσ) (fun x hx => ?_)
+      exact ihbody x hx (cbody x hx) (ρ := ρ.push x.T)
+        (σ := σ.lift)
+        (fun | 0 => .bvar .rfl | i + 1 => (hσ i).weak)
+        (fun | 0 => .bvar | i + 1 => (cσ i).weak hP)
+  | forallE hb hb' hdom hbody hle ihb ihb' ihbody =>
+    cases children with
+    | forallE cb cb' cbody =>
+      refine .forallE (ihb cb hσ cσ) (ihb' cb' hσ cσ)
+        (fun x hx => ?_)
+      exact ihbody x hx (cbody x hx) (ρ := ρ.push x.T)
+        (σ := σ.lift)
+        (fun | 0 => .bvar .rfl | i + 1 => (hσ i).weak)
+        (fun | 0 => .bvar | i + 1 => (cσ i).weak hP)
+  | const hreg hlen hle hty hA hC hR ihA ihR =>
+    cases children with
+    | const cA pR cR =>
+      exact .const
+        (cA.closed hP (Params.henv.closedC hreg).mkInstS nofun)
+        (fun m e hr => hP (hR m e hr.2) hr.1 nofun (pR m e hr.2))
+        (fun m e hr => (cR m e hr.2).closed hP hr.1 nofun)
+
+/-- Instantiate the leading variable of a proof-relevant witness without
+forgetting the witness tree on either the body or the argument. -/
+noncomputable def LE_Interp.Witness.inst
+    (H : LE_Interp.Witness (ρ.push a) m F)
+    (hA : LE_Interp.Witness ρ a A) :
+    LE_Interp.Witness ρ m (F.inst A) :=
+  H.subst fun
+    | 0 => hA
+    | _ + 1 => .bvar .rfl
+
+/-- Leading-variable instantiation combines the retained body and argument
+trees without choosing a new semantic derivation. -/
+theorem LE_Interp.Witness.RDeepChildren.inst
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {H : LE_Interp.Witness (ρ.push a) m F}
+    (children : H.RDeepChildren P)
+    {hA : LE_Interp.Witness ρ a A}
+    (childrenA : hA.RDeepChildren P) :
+    (H.inst hA).RDeepChildren P := by
+  let hσ : ∀ i, LE_Interp.Witness ρ ((ρ.push a) i) ((Subst.one A) i)
+    | 0 => hA
+    | _ + 1 => .bvar .rfl
+  have cσ : ∀ i, (hσ i).RDeepChildren P := by
+    intro i
+    cases i with
+    | zero => exact childrenA
+    | succ i => exact .bvar
+  exact children.subst hP hσ cσ
+
 theorem LE_Interp.weak'_iff (l : Lift) (h : ∀ i, ρ i = ρ' (l.liftVar i)) :
     LE_Interp ρ' m (M.lift' l) ↔ LE_Interp ρ m M := by
   refine ⟨fun H => ?_, fun H => ?_⟩
@@ -3714,7 +6035,7 @@ theorem LE_Interp.weak'_iff (l : Lift) (h : ∀ i, ρ i = ρ' (l.liftVar i)) :
       exact ih_body y hy _ (fun i => by cases i <;> simp [Valuation.push, h]) rfl
     | const h1 h2 h3 h4 _ h6 _ ih1 ih2 =>
       refine .const h1 h2 h3 h4 ?_ h6.closed ?_
-      · exact ih1 _ h <| (Params.henv.closedC h1).mkS.instL.lift'_eq .zero
+      · exact ih1 _ h <| (Params.henv.closedC h1).mkInstS.lift'_eq .zero
       · rintro m A ⟨a1, a2⟩; exact ih2 _ _ a2 _ h <| a1.lift'_eq .zero
   · induction H generalizing ρ' l with
     | bot => exact .bot
@@ -3729,7 +6050,7 @@ theorem LE_Interp.weak'_iff (l : Lift) (h : ∀ i, ρ i = ρ' (l.liftVar i)) :
       exact ih_body y hy l.cons fun i => by cases i <;> simp [Valuation.push, h]
     | const h1 h2 h3 h4 _ h6 _ ih1 ih2 =>
       refine .const h1 h2 h3 h4 ?_ h6.closed ?_
-      · exact (Params.henv.closedC h1).mkS.instL.lift'_eq .zero ▸ ih1 _ h
+      · exact (Params.henv.closedC h1).mkInstS.lift'_eq .zero ▸ ih1 _ h
       · rintro m A ⟨a1, a2⟩; exact a1.lift'_eq .zero ▸ ih2 _ _ a2 _ h
 
 theorem LE_Interp.weak_iff : LE_Interp (ρ.push x) m M.lift ↔ LE_Interp ρ m M :=
@@ -3738,6 +6059,22 @@ theorem LE_Interp.weak_iff : LE_Interp (ρ.push x) m M.lift ↔ LE_Interp ρ m M
 theorem LE_Interp.weak (H : LE_Interp ρ m M) : LE_Interp (ρ.push x) m M.lift :=
   weak_iff.2 H
 
+theorem LE_Interp.Witness.unlift'_toInterp
+    {ρ ρ' : Valuation} {m : TShape} {M : SExpr}
+    (l : Lift) (hρ : ∀ i, ρ i = ρ' (l.liftVar i))
+    (H : LE_Interp.Witness ρ' m (M.lift' l)) :
+    (H.unlift' l hρ).toInterp =
+      (LE_Interp.weak'_iff l hρ).1 H.toInterp :=
+  Subsingleton.elim _ _
+
+theorem LE_Interp.Witness.lift'_toInterp
+    {ρ ρ' : Valuation} {m : TShape} {M : SExpr}
+    (l : Lift) (hρ : ∀ i, ρ i = ρ' (l.liftVar i))
+    (H : LE_Interp.Witness ρ m M) :
+    (H.lift' l hρ).toInterp =
+      (LE_Interp.weak'_iff l hρ).2 H.toInterp :=
+  Subsingleton.elim _ _
+
 theorem LE_Interp.Const.compat_mismatch {rargs1 rargs2 : List (WShape n)} {m : TShape}
     (h_len : rargs2.length < rargs1.length) (H1 : Const c ls R rargs1 m)
     (H2 : Params.classify c = some (.ctor rargs2.length) ∨
@@ -4063,6 +6400,393 @@ theorem LE_Interp.compat_join {m₁ m₂ : TShape}
     · have aty := h4.isType.join ac a4.isType
       exact .join hc1 (aty.mono_r b3 h4) (aty.mono_r b4 a4)
 
+/-- Merge two compatible proof-relevant interpretations without losing the
+exact constructor trees or abstract constant callbacks retained by either
+side.  The recursive predicate is used only at constant `R` edges; its four
+closure laws are exactly the operations performed while joining evaluator
+results and saturating binder observations. -/
+theorem LE_Interp.Witness.RDeepChildren.compat_join
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (laws : LE_Interp.Witness.RDeepChildren.JoinLaws P)
+    (hρ : ρ'.LE ρ)
+    {H₁ : LE_Interp.Witness ρ' m₁ M}
+    (c₁ : H₁.RDeepChildren P)
+    {H₂ : LE_Interp.Witness ρ m₂ M}
+    (c₂ : H₂.RDeepChildren P) :
+    m₁.Compat m₂ ∧
+      ∃ HJ : LE_Interp.Witness ρ (m₁.join m₂) M,
+        HJ.RDeepChildren P := by
+  have mk {m₁ m₂ m ρ M}
+      (hle₁ : m₁ ≤ m) (hle₂ : m₂ ≤ m)
+      {H : LE_Interp.Witness ρ m M}
+      (children : H.RDeepChildren P) :
+      m₁.Compat m₂ ∧
+        ∃ HJ : LE_Interp.Witness ρ (m₁.join m₂) M,
+          HJ.RDeepChildren P := by
+    have hc := TShape.Compat.def'.2 ⟨m, hle₁, hle₂⟩
+    have hjoin : m₁.join m₂ ≤ m :=
+      (TShape.Join.mk hc _).2 ⟨hle₁, hle₂⟩
+    exact ⟨hc, H.mono hjoin, children.mono hjoin⟩
+  have bot_r {m₁ n₂ ρ' ρ M}
+      (hρ : ρ'.LE ρ)
+      {H : LE_Interp.Witness ρ' m₁ M}
+      (children : H.RDeepChildren P) :
+      m₁.Compat (WShape.bot (n := n₂)).T ∧
+        ∃ HJ : LE_Interp.Witness ρ
+            (m₁.join (WShape.bot (n := n₂)).T) M,
+          HJ.RDeepChildren P :=
+    mk .rfl TShape.bot_le' (children.mono_l laws.mono_l hρ)
+  induction H₁ generalizing ρ m₂ with
+  | bot => exact mk TShape.bot_le' .rfl c₂
+  | sort hle =>
+    cases c₁
+    cases H₂ with
+    | bot => exact bot_r hρ (.sort (h := hle))
+    | sort hle₂ =>
+      cases c₂
+      exact mk (hle.trans (TShape.sort_eqv.2))
+        (hle₂.trans TShape.sort_eqv.2) (.sort (h := TShape.LE.rfl))
+  | bvar hle =>
+    cases c₁
+    cases H₂ with
+    | bot => exact bot_r hρ (.bvar (h := hle))
+    | bvar hle₂ =>
+      cases c₂
+      exact mk (hle.trans (hρ _)) hle₂ (.bvar (h := TShape.LE.rfl))
+  | @app ρ₁ n₁ f₁ F A m₁ a₁ hf ha hle ihf iha =>
+    cases c₁ with
+    | app cf ca =>
+      cases H₂ with
+      | bot =>
+        exact bot_r hρ (H := .app hf ha hle) (.app cf ca)
+      | @app _ n₂ f₂ _ _ _ a₂ hf₂ ha₂ hle₂ =>
+        cases c₂ with
+        | app cf₂ ca₂ =>
+          obtain ⟨hcf, hfj, cfj⟩ := ihf hρ cf cf₂
+          obtain ⟨hca, haj, caj⟩ := iha hρ ca ca₂
+          have hfl := (TShape.Join.mk hcf).le
+          have hal := (TShape.Join.mk hca).le
+          have le' : (f₁.T.join f₂.T).1 ≤ max n₁ n₂ + 1 := by
+            simp [TShape.join]
+          have hfjLe := (TShape.lift_eqv le').1
+          let HJ := LE_Interp.Witness.app
+            (hfj.mono hfjLe) haj TShape.LE.rfl
+          have cHJ : HJ.RDeepChildren P := by
+            dsimp only [HJ]
+            exact .app (cfj.mono hfjLe) caj
+          exact mk
+            (hle.trans <| TShape.app_mono
+              (hfl.1.trans (TShape.lift_eqv le').2) hal.1)
+            (hle₂.trans <| TShape.app_mono
+              (hfl.2.trans (TShape.lift_eqv le').2) hal.2)
+            cHJ
+  | @lam ρ₁ n₁ a₁ A f₁ F m₁ ha hdom he hle iha ihf =>
+    cases c₁ with
+    | lam ca cbody =>
+      cases H₂ with
+      | bot =>
+        exact bot_r hρ (H := .lam ha hdom he hle) (.lam ca cbody)
+      | @lam _ n₂ a₂ _ f₂ _ _ ha₂ hdom₂ he₂ hle₂ =>
+        cases c₂ with
+        | lam ca₂ cbody₂ =>
+          obtain ⟨hca, ia, cia⟩ := iha hρ ca ca₂
+          have hC {x₁ y₁ x₂ y₂}
+              (hm₁ : (x₁, y₁) ∈ f₁) (hm₂ : (x₂, y₂) ∈ f₂)
+              (hc : x₁.T.Compat x₂.T) :
+              y₁.T.Compat y₂.T ∧
+                ∃ hJ : LE_Interp.Witness
+                    (ρ.push (x₁.T.join x₂.T)) (y₁.T.join y₂.T) F,
+                  hJ.RDeepChildren P := by
+            have ⟨j₁, j₂⟩ := (TShape.Join.mk hc).le
+            have ⟨x'₁, hx1_le, hx1, happ1⟩ := WShape.HasDom.iff.1 hdom x₁
+            have ⟨x'₂, hx2_le, hx2, happ2⟩ := WShape.HasDom.iff.1 hdom₂ x₂
+            let hi₂ := (he₂ x'₂ hx2).mono (WShape.LE.T happ2)
+              |>.mono_l (Valuation.LE.push.2
+                ⟨Valuation.LE.rfl, hx2_le.T.trans j₂⟩)
+            have ci₂ : hi₂.RDeepChildren P := by
+              dsimp only [hi₂]
+              exact ((cbody₂ x'₂ hx2).mono (WShape.LE.T happ2))
+                |>.mono_l laws.mono_l (Valuation.LE.push.2
+                  ⟨Valuation.LE.rfl, hx2_le.T.trans j₂⟩)
+            obtain ⟨hc', hJ, cJ⟩ := ihf x'₁ hx1
+              (Valuation.LE.push.2 ⟨hρ, hx1_le.T.trans j₁⟩)
+              (cbody x'₁ hx1) ci₂
+            exact mk
+              ((WShapeFun.app_of_mem hm₁).2.T.trans happ1.T
+                |>.trans (TShape.Join.mk hc').le.1)
+              ((WShapeFun.app_of_mem hm₂).2.T.trans
+                (TShape.Join.mk hc').le.2) cJ
+          have le₁ := Nat.le_max_left n₁ n₂
+          have le₂ := Nat.le_max_right n₁ n₂
+          have cf : WShapeFun.Compat
+              (f₁.lift (max n₁ n₂)) (f₂.lift (max n₁ n₂)) := by
+            simp only [WShapeFun.Compat.def, Prod.forall, le₂,
+              WShapeFun.mem_lift, le₁]
+            rintro _ _ ⟨x₁, y₁, hm₁, rfl, rfl⟩
+              _ _ ⟨x₂, y₂, hm₂, rfl, rfl⟩ hc
+            exact (hC hm₁ hm₂ hc).1
+          let fJ := (f₁.lift (max n₁ n₂)).join
+            (f₂.lift (max n₁ n₂))
+          have jf : WShapeFun.Join (f₁.lift (max n₁ n₂))
+              (f₂.lift (max n₁ n₂)) fJ := by
+            simpa only [fJ] using WShapeFun.Join.mk cf
+          have hdom₁ := (WShape.HasDom.lift le₁).2 hdom
+          have hdom₂' := (WShape.HasDom.lift le₂).2 hdom₂
+          have ca_w : WShape.Compat (a₁.lift _) (a₂.lift _) :=
+            (TShape.Compat.def le₁ le₂).1 hca
+          have hdomJ := hdom₁.join cf ca_w hdom₂'
+          have bodyJ (x : WShape (max n₁ n₂))
+              (hx : x.HasType (a₁.lift _ |>.join (a₂.lift _))) :
+              ∃ hJ : LE_Interp.Witness (ρ.push x.T) (fJ.app x).T F,
+                hJ.RDeepChildren P := by
+            have ⟨x₁', a1, a2'⟩ := WShapeFun.app_eq (f₁.lift _) x
+            have ⟨x₂', b1, b2'⟩ := WShapeFun.app_eq (f₂.lift _) x
+            have ⟨ox₁, oy₁, hm₁, hx₁eq, hy₁eq⟩ :=
+              (WShapeFun.mem_lift le₁).1 a2'
+            have ⟨ox₂, oy₂, hm₂, hx₂eq, hy₂eq⟩ :=
+              (WShapeFun.mem_lift le₂).1 b2'
+            have a1' : ox₁.T ≤ x.T :=
+              ((TShape.LE.lift_l le₁).2 .rfl).trans
+                (hx₁eq ▸ a1).T
+            have b1' : ox₂.T ≤ x.T :=
+              ((TShape.LE.lift_l le₂).2 .rfl).trans
+                (hx₂eq ▸ b1).T
+            have hc := TShape.Compat.def'.2 ⟨x.T, a1', b1'⟩
+            obtain ⟨_, hJ, cJ⟩ := hC hm₁ hm₂ hc
+            have hρx : (ρ.push (ox₁.T.join ox₂.T)).LE (ρ.push x.T) :=
+              Valuation.LE.push.2
+              ⟨Valuation.LE.rfl,
+                (TShape.Join.mk hc x.T).2 ⟨a1', b1'⟩⟩
+            have ja := hy₁eq ▸ hy₂eq ▸ jf.app_l x
+            have oy_c := WShape.Compat.iff.2 ⟨_, ja.le.1, ja.le.2⟩
+            have hout := (ja _).2 (WShape.Join.mk oy_c).le |>.T
+            exact ⟨hJ.mono_l hρx |>.mono hout,
+              (cJ.mono_l laws.mono_l hρx).mono hout⟩
+          let hbodyJ := fun x hx => Classical.choose (bodyJ x hx)
+          have cbodyJ : ∀ x hx, (hbodyJ x hx).RDeepChildren P :=
+            fun x hx => Classical.choose_spec (bodyJ x hx)
+          let HJ := LE_Interp.Witness.lam ia hdomJ hbodyJ TShape.LE.rfl
+          have cHJ : HJ.RDeepChildren P := by
+            dsimp only [HJ]
+            exact .lam cia cbodyJ
+          exact mk
+            (hle.trans <| (TShape.LE.lift_l (Nat.succ_le_succ le₁)).2 <|
+              WShape.lift_lam' le₁ ▸
+                WShape.lam'_le_lam'.2 jf.le.1)
+            (hle₂.trans <| (TShape.LE.lift_l (Nat.succ_le_succ le₂)).2 <|
+              WShape.lift_lam' le₂ ▸
+                WShape.lam'_le_lam'.2 jf.le.2)
+            cHJ
+  | @forallE ρ₁ n₁ b₁ B b₁' f₁ F m₁ hb ha hdom he hle ihb iha ihf =>
+    cases c₁ with
+    | forallE cb ca cbody =>
+      cases H₂ with
+      | bot =>
+        exact bot_r hρ (H := .forallE hb ha hdom he hle)
+          (.forallE cb ca cbody)
+      | @forallE _ n₂ b₂ _ b₂' f₂ _ _ hb₂ ha₂ hdom₂ he₂ hle₂ =>
+        cases c₂ with
+        | forallE cb₂ ca₂ cbody₂ =>
+          obtain ⟨hcb, ib, cib⟩ := ihb hρ cb cb₂
+          obtain ⟨hca, ia, cia⟩ := iha hρ ca ca₂
+          have hC {x₁ y₁ x₂ y₂}
+              (hm₁ : (x₁, y₁) ∈ f₁) (hm₂ : (x₂, y₂) ∈ f₂)
+              (hc : x₁.T.Compat x₂.T) :
+              y₁.T.Compat y₂.T ∧
+                ∃ hJ : LE_Interp.Witness
+                    (ρ.push (x₁.T.join x₂.T)) (y₁.T.join y₂.T) F,
+                  hJ.RDeepChildren P := by
+            have ⟨j₁, j₂⟩ := (TShape.Join.mk hc).le
+            have ⟨x'₁, hx1_le, hx1, happ1⟩ := WShape.HasDom.iff.1 hdom x₁
+            have ⟨x'₂, hx2_le, hx2, happ2⟩ := WShape.HasDom.iff.1 hdom₂ x₂
+            let hi₂ := (he₂ x'₂ hx2).mono (WShape.LE.T happ2)
+              |>.mono_l (Valuation.LE.push.2
+                ⟨Valuation.LE.rfl, hx2_le.T.trans j₂⟩)
+            have ci₂ : hi₂.RDeepChildren P := by
+              dsimp only [hi₂]
+              exact ((cbody₂ x'₂ hx2).mono (WShape.LE.T happ2))
+                |>.mono_l laws.mono_l (Valuation.LE.push.2
+                  ⟨Valuation.LE.rfl, hx2_le.T.trans j₂⟩)
+            obtain ⟨hc', hJ, cJ⟩ := ihf x'₁ hx1
+              (Valuation.LE.push.2 ⟨hρ, hx1_le.T.trans j₁⟩)
+              (cbody x'₁ hx1) ci₂
+            exact mk
+              ((WShapeFun.app_of_mem hm₁).2.T.trans happ1.T
+                |>.trans (TShape.Join.mk hc').le.1)
+              ((WShapeFun.app_of_mem hm₂).2.T.trans
+                (TShape.Join.mk hc').le.2) cJ
+          have le₁ := Nat.le_max_left n₁ n₂
+          have le₂ := Nat.le_max_right n₁ n₂
+          have cf : WShapeFun.Compat
+              (f₁.lift (max n₁ n₂)) (f₂.lift (max n₁ n₂)) := by
+            simp only [WShapeFun.Compat.def, Prod.forall, le₂,
+              WShapeFun.mem_lift, le₁]
+            rintro _ _ ⟨x₁, y₁, hm₁, rfl, rfl⟩
+              _ _ ⟨x₂, y₂, hm₂, rfl, rfl⟩ hc
+            exact (hC hm₁ hm₂ hc).1
+          let fJ := (f₁.lift (max n₁ n₂)).join
+            (f₂.lift (max n₁ n₂))
+          have jf : WShapeFun.Join (f₁.lift (max n₁ n₂))
+              (f₂.lift (max n₁ n₂)) fJ := by
+            simpa only [fJ] using WShapeFun.Join.mk cf
+          have cb_w : WShape.Compat (b₁.lift _) (b₂.lift _) :=
+            (TShape.Compat.def le₁ le₂).1 hcb
+          let bJ := (b₁.lift (max n₁ n₂)).join
+            (b₂.lift (max n₁ n₂))
+          have jb : WShape.Join (b₁.lift (max n₁ n₂))
+              (b₂.lift (max n₁ n₂)) bJ := by
+            simpa only [bJ] using WShape.Join.mk cb_w
+          have hdom₁ := (WShape.HasDom.lift le₁).2 hdom
+          have hdom₂' := (WShape.HasDom.lift le₂).2 hdom₂
+          have ca_w : WShape.Compat (b₁'.lift _) (b₂'.lift _) :=
+            (TShape.Compat.def le₁ le₂).1 hca
+          have hdomJ := hdom₁.join cf ca_w hdom₂'
+          have bodyJ (x : WShape (max n₁ n₂))
+              (hx : x.HasType (b₁'.lift _ |>.join (b₂'.lift _))) :
+              ∃ hJ : LE_Interp.Witness (ρ.push x.T) (fJ.app x).T F,
+                hJ.RDeepChildren P := by
+            have ⟨x₁', a1, a2'⟩ := WShapeFun.app_eq (f₁.lift _) x
+            have ⟨x₂', b1, b2'⟩ := WShapeFun.app_eq (f₂.lift _) x
+            have ⟨ox₁, oy₁, hm₁, hx₁eq, hy₁eq⟩ :=
+              (WShapeFun.mem_lift le₁).1 a2'
+            have ⟨ox₂, oy₂, hm₂, hx₂eq, hy₂eq⟩ :=
+              (WShapeFun.mem_lift le₂).1 b2'
+            have a1' : ox₁.T ≤ x.T :=
+              ((TShape.LE.lift_l le₁).2 .rfl).trans
+                (hx₁eq ▸ a1).T
+            have b1' : ox₂.T ≤ x.T :=
+              ((TShape.LE.lift_l le₂).2 .rfl).trans
+                (hx₂eq ▸ b1).T
+            have hc := TShape.Compat.def'.2 ⟨x.T, a1', b1'⟩
+            obtain ⟨_, hJ, cJ⟩ := hC hm₁ hm₂ hc
+            have hρx : (ρ.push (ox₁.T.join ox₂.T)).LE (ρ.push x.T) :=
+              Valuation.LE.push.2
+                ⟨Valuation.LE.rfl,
+                  (TShape.Join.mk hc x.T).2 ⟨a1', b1'⟩⟩
+            have ja := hy₁eq ▸ hy₂eq ▸ jf.app_l x
+            have oy_c := WShape.Compat.iff.2 ⟨_, ja.le.1, ja.le.2⟩
+            have hout := (ja _).2 (WShape.Join.mk oy_c).le |>.T
+            exact ⟨hJ.mono_l hρx |>.mono hout,
+              (cJ.mono_l laws.mono_l hρx).mono hout⟩
+          let hbodyJ := fun x hx => Classical.choose (bodyJ x hx)
+          have cbodyJ : ∀ x hx, (hbodyJ x hx).RDeepChildren P :=
+            fun x hx => Classical.choose_spec (bodyJ x hx)
+          let HJ := LE_Interp.Witness.forallE ib ia hdomJ hbodyJ TShape.LE.rfl
+          have cHJ : HJ.RDeepChildren P := by
+            dsimp only [HJ]
+            exact .forallE cib cia cbodyJ
+          exact mk
+            (hle.trans <| (TShape.LE.lift_l (Nat.succ_le_succ le₁)).2 <|
+              WShape.lift_forallE le₁ ▸
+                WShape.forallE_le_forallE.2 ⟨jb.le.1, jf.le.1⟩)
+            (hle₂.trans <| (TShape.LE.lift_l (Nat.succ_le_succ le₂)).2 <|
+              WShape.lift_forallE le₂ ▸
+                WShape.forallE_le_forallE.2 ⟨jb.le.2, jf.le.2⟩)
+            cHJ
+  | @const _ _ _ mRoot₁ mEval₁ _ aTy₁ _ R₁
+      hreg hlen hle hty hA hC hR ihA ihR =>
+    cases c₁ with
+    | const cA pR cR =>
+      cases H₂ with
+      | bot =>
+        exact bot_r hρ (H := .const hreg hlen hle hty hA hC hR)
+          (.const cA pR cR)
+      | @const _ _ _ _ mEval₂ _ aTy₂ _ R₂
+          hreg₂ hlen₂ hle₂ hty₂ hA₂ hC₂ hR₂ =>
+        cases c₂ with
+        | const cA₂ pR₂ cR₂ =>
+          cases hreg.symm.trans hreg₂
+          let R₃ (m : TShape) (e : SExpr) : Prop :=
+            ∃ H : LE_Interp.Witness ρ m e, H.RDeepChildren P ∧ P H
+          have R₃_mono {a a' A} (le : a ≤ a') : R₃ a' A → R₃ a A := by
+            rintro ⟨H, cH, pH⟩
+            exact ⟨H.mono le, cH.mono le, laws.mono H le pH⟩
+          have mkR {m₁ m₂ m : TShape} {e : SExpr}
+              (hle₁ : m₁ ≤ m) (hle₂ : m₂ ≤ m)
+              {H : LE_Interp.Witness ρ m e}
+              (cH : H.RDeepChildren P) (pH : P H) :
+              m₁.Compat m₂ ∧ R₃ (m₁.join m₂) e := by
+            have hc := TShape.Compat.def'.2 ⟨m, hle₁, hle₂⟩
+            have hJle : m₁.join m₂ ≤ m :=
+              (TShape.Join.mk hc _).2 ⟨hle₁, hle₂⟩
+            exact ⟨hc, H.mono hJle, cH.mono hJle,
+              laws.mono H hJle pH⟩
+          let Rd (R : TShape → SExpr → Prop) m e :=
+            m ≤ .bot ∨ ∃ m', m ≤ m' ∧ R m' e
+          have hC₁ := hC.mono (R' := Rd R₁) TShape.LE.rfl
+            (fun le hr => Or.inr ⟨_, le, hr⟩)
+          have hC₂ := hC₂.mono (R' := Rd R₂) TShape.LE.rfl
+            (fun le hr => Or.inr ⟨_, le, hr⟩)
+          have rd_mono {R a a' A} (le : a ≤ a') : Rd R a' A → Rd R a A :=
+            .imp (by exact le.trans) fun ⟨_, le', hr⟩ => by
+              exact ⟨_, le.trans le', hr⟩
+          have hRR : ∀ {m₁ m₂ A}, Rd R₁ m₁ A → Rd R₂ m₂ A →
+              m₁.Compat m₂ ∧ R₃ (m₁.join m₂) A := by
+            rintro m₁ m₂ A (hb₁ | ⟨m₁', le₁, hr₁⟩)
+              (hb₂ | ⟨m₂', le₂, hr₂⟩)
+            · exact mkR hb₁ hb₂ (H := LE_Interp.Witness.bot)
+                .bot laws.bot
+            · exact mkR (hb₁.trans TShape.bot_le') le₂
+                (cR₂ m₂' A hr₂) (pR₂ m₂' A hr₂)
+            · let H₁ := (hR m₁' A hr₁).mono_l hρ
+              have cH₁ : H₁.RDeepChildren P := by
+                dsimp only [H₁]
+                exact (cR m₁' A hr₁).mono_l laws.mono_l hρ
+              have pH₁ : P H₁ := by
+                dsimp only [H₁]
+                exact laws.mono_l (hR m₁' A hr₁) hρ
+                  (pR m₁' A hr₁)
+              exact mkR le₁ (hb₂.trans TShape.bot_le') cH₁ pH₁
+            · let H₁ := (hR m₁' A hr₁).mono_l hρ
+              let H₂ := hR₂ m₂' A hr₂
+              have cH₁ : H₁.RDeepChildren P := by
+                dsimp only [H₁]
+                exact (cR m₁' A hr₁).mono_l laws.mono_l hρ
+              have pH₁ : P H₁ := by
+                dsimp only [H₁]
+                exact laws.mono_l (hR m₁' A hr₁) hρ
+                  (pR m₁' A hr₁)
+              have cH₂ : H₂.RDeepChildren P := by
+                dsimp only [H₂]
+                exact cR₂ m₂' A hr₂
+              have pH₂ : P H₂ := by
+                dsimp only [H₂]
+                exact pR₂ m₂' A hr₂
+              obtain ⟨hc, hJ, cJ⟩ := ihR m₁' A hr₁ hρ
+                (cR m₁' A hr₁) cH₂
+              have pJ : P hJ := laws.join H₁ H₂ hJ pH₁ pH₂
+              exact mkR
+                (le₁.trans (TShape.Join.mk hc).le.1)
+                (le₂.trans (TShape.Join.mk hc).le.2) cJ pJ
+          obtain ⟨hcEval, hCEval⟩ :=
+            (hC₁.lift (Nat.le_max_left ..) rd_mono).compat_join
+              (R₃ := R₃) .nil
+              (hC₂.lift (Nat.le_max_right ..) rd_mono)
+              (.inl TShape.bot_le') (.inl TShape.bot_le') R₃_mono hRR
+          obtain ⟨hcTy, hATyJ, cATyJ⟩ := ihA hρ cA cA₂
+          have ⟨evalLe₁, evalLe₂⟩ := (TShape.Join.mk hcEval).le
+          have ⟨tyLe₁, tyLe₂⟩ := (TShape.Join.mk hcTy).le
+          have hcRoot := TShape.Compat.mono hle hle₂ hcEval
+          have hrootLe : mRoot₁.join m₂ ≤ mEval₁.join mEval₂ :=
+            (TShape.Join.mk hcRoot _).2
+              ⟨hle.trans evalLe₁, hle₂.trans evalLe₂⟩
+          have hresultTy : (mEval₁.join mEval₂).HasType
+              (aTy₁.join aTy₂) := by
+            have aty := hty.isType.join hcTy hty₂.isType
+            exact .join hcEval (aty.mono_r tyLe₁ hty)
+              (aty.mono_r tyLe₂ hty₂)
+          let hRJ := fun m e (hr : R₃ m e) => Classical.choose hr
+          have pRJ : ∀ m e hr, P (hRJ m e hr) :=
+            fun m e hr => (Classical.choose_spec hr).2
+          have cRJ : ∀ m e hr, (hRJ m e hr).RDeepChildren P :=
+            fun m e hr => (Classical.choose_spec hr).1
+          let HJ := LE_Interp.Witness.const hreg hlen hrootLe hresultTy
+            hATyJ hCEval hRJ
+          have cHJ : HJ.RDeepChildren P := by
+            dsimp only [HJ]
+            exact .const cATyJ pRJ cRJ
+          exact ⟨hcRoot, HJ, cHJ⟩
+
 theorem LE_Interp.compat (H1 : LE_Interp ρ m₁ M) (H2 : LE_Interp ρ m₂ M) : m₁.Compat m₂ :=
   (compat_join .rfl H1 H2).1
 
@@ -4074,6 +6798,99 @@ theorem LE_Interp.join (J : m₁.Join m₂ m) (H1 : LE_Interp ρ m₁ M) (H2 : L
     LE_Interp ρ m M :=
   (H1.join' H2).mono ((J _).2 (TShape.Join.mk (H1.compat H2)).le)
 
+/-- Invert an interpreted `appN` tower without reselecting its fixed-head
+witness.
+
+The returned capture map joins repeated observations of the same path.  Only
+those capture observations are proof-independent; `hhead` is the literal
+sub-witness obtained by peeling `H`.  Thus a caller can rebuild the enclosing
+constant with `hhead.LowerEdge` and know that every fixed RHS edge realizes by
+root-lowering this exact witness. -/
+theorem LE_Interp.Witness.appNVarsFocused
+    {p : Pattern} {f : p.RHS} {paths : List p.Path}
+    {capture : p.Path → SExpr} {out : TShape}
+    (H : LE_Interp.Witness ρ out
+      ((Pattern.RHS.appN f (paths.map fun path => .var path)).applyS
+        ls capture))
+    (hnonbot : ¬out ≤ TShape.bot) :
+    ∃ mcap : p.Path → TShape,
+      (∀ path, LE_Interp ρ (mcap path) (capture path)) ∧
+      ∃ head, ∃ hhead : LE_Interp.Witness ρ head (f.applyS ls capture),
+        LE_Interp.RHS.ShapeSpine mcap head paths out := by
+  classical
+  induction paths generalizing f out with
+  | nil =>
+    refine ⟨fun _ => TShape.bot, fun _ => .bot, out, H, ?_⟩
+    exact .nil
+  | cons path paths ih =>
+    simp only [List.map_cons, Pattern.RHS.appN] at H
+    obtain ⟨mcap, hcap, head, hhead, hspine⟩ := ih H hnonbot
+    have hheadNonbot : ¬head ≤ TShape.bot := by
+      intro hbot
+      exact hnonbot (hspine.le_bot hbot)
+    cases hhead with
+    | bot => exact (hheadNonbot TShape.bot_eqv.1).elim
+    | @app _ n funShape _ _ _ argShape hfun harg happ =>
+      have hargInterp : LE_Interp ρ argShape.T (capture path) := by
+        simpa only [Pattern.RHS.applyS] using harg.toInterp
+      let mcap' : p.Path → TShape := fun current =>
+        if current = path then argShape.T.join (mcap current)
+        else mcap current
+      have htail : ∀ current, mcap current ≤ mcap' current := by
+        intro current
+        dsimp only [mcap']
+        split <;> rename_i heq
+        · subst current
+          exact (TShape.Join.mk (hargInterp.compat (hcap path))).le.2
+        · exact TShape.LE.rfl
+      have hcurrent : argShape.T ≤ mcap' path := by
+        simp only [mcap', if_pos rfl]
+        exact (TShape.Join.mk (hargInterp.compat (hcap path))).le.1
+      refine ⟨mcap', ?_, funShape.T, hfun, ?_⟩
+      · intro current
+        dsimp only [mcap']
+        split <;> rename_i heq
+        · subst current
+          exact hargInterp.join' (hcap path)
+        · exact hcap current
+      · exact .cons hcurrent happ (hspine.mono_l htail)
+
+/-- Specialize `appNVarsFocused` to the registered fixed tower selected by an
+iota descriptor. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.focusedShapeSpine
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {out : TShape}
+    (H : LE_Interp.Witness ρ out (r.1.applyS ls capture))
+    (hnonbot : ¬out ≤ TShape.bot) :
+    ∃ mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape,
+      (∀ path, LE_Interp ρ (mcap path) (capture path)) ∧
+      ∃ head, ∃ hhead : LE_Interp.Witness ρ head
+          (SExpr.mkInst ls rule.df.rhs),
+        LE_Interp.RHS.ShapeSpine mcap head rule.capturePaths out := by
+  rw [rule.rhsTower] at H
+  exact H.appNVarsFocused hnonbot
+
+/-- Rebuild the registered iota RHS using the singleton evaluator relation
+generated by the exact fixed-head witness selected above. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.focusedRHS
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) {ls : List SLevel}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape}
+    {head out : TShape}
+    (hhead : LE_Interp.Witness ρ head (SExpr.mkInst ls rule.df.rhs))
+    (spine : LE_Interp.RHS.ShapeSpine
+      mcap head rule.capturePaths out) :
+    LE_Interp.RHS ls mcap hhead.LowerEdge out r.1 := by
+  rw [rule.rhsTower]
+  exact spine.to_appN (.const
+    (LE_Interp.Witness.LowerEdge.self hhead))
+
 theorem LE_Interp.subst : LE_Interp ρ m (M.subst σ) ↔
     ∃ ρ', LE_Interp ρ' m M ∧ ∀ i, LE_Interp ρ (ρ' i) (σ i) := by
   refine ⟨fun H => ?_, ?_⟩
@@ -4201,7 +7018,7 @@ theorem LE_Interp.subst : LE_Interp ρ m (M.subst σ) ↔
       | bvar => exact bvar eq (.const h1 h2 h3 h4 h5 h6 h7) | const => ?_ | _ => cases eq
       cases eq
       refine ⟨.nil, .const h1 h2 h3 h4 ?_ h6.closed fun m e ⟨a1, a2⟩ => ?_, fun _ => .bot⟩
-      · exact (closed_iff (Params.henv.closedC h1).mkS.instL).1 h5
+      · exact (closed_iff (Params.henv.closedC h1).mkInstS).1 h5
       · exact (closed_iff a1).1 (h7 m e a2)
   · rintro ⟨ρ', H, h⟩
     induction H generalizing ρ σ with
@@ -4217,7 +7034,7 @@ theorem LE_Interp.subst : LE_Interp ρ m (M.subst σ) ↔
       exact ih_body y hy fun | 0 => .bvar0 | i + 1 => (h i).weak
     | const h1 h2 h3 h4 _ h6 _ ih1 ih2 =>
       refine .const h1 h2 h3 h4 ?_ h6.closed fun _ _ ⟨a1, a2⟩ => ?_
-      · exact (Params.henv.closedC h1).mkS.instL.subst_eq .zero ▸ ih1 h
+      · exact (Params.henv.closedC h1).mkInstS.subst_eq .zero ▸ ih1 h
       · exact a1.subst_eq .zero ▸ ih2 _ _ a2 h
 
 theorem LE_Interp.inst : LE_Interp ρ f (F.inst A) ↔
@@ -4228,6 +7045,21 @@ theorem LE_Interp.inst : LE_Interp ρ f (F.inst A) ↔
     intro | 0 => exact .rfl | i+1 => exact (bvar_iff.1 (hσ (i+1)) :)
   · exact (LE_Interp.subst (σ := .one A)).2 ⟨_, hF, fun | 0 => hA | _+1 => .bvar'⟩
 
+theorem LE_Interp.Witness.subst_toInterp
+    {σ : Subst}
+    (H : LE_Interp.Witness ρ' m M)
+    (hσ : ∀ i, LE_Interp.Witness ρ (ρ' i) (σ i)) :
+    (H.subst hσ).toInterp =
+      (LE_Interp.subst.2 ⟨ρ', H.toInterp, fun i => (hσ i).toInterp⟩) :=
+  Subsingleton.elim _ _
+
+theorem LE_Interp.Witness.inst_toInterp
+    (H : LE_Interp.Witness (ρ.push a) m F)
+    (hA : LE_Interp.Witness ρ a A) :
+    (H.inst hA).toInterp =
+      (LE_Interp.inst.2 ⟨a, H.toInterp, hA.toInterp⟩) :=
+  Subsingleton.elim _ _
+
 theorem LE_Interp.forallE_inv {b} {f : WShapeFun n} {B F}
     (H : LE_Interp ρ (WShape.T (n := n+1) (.forallE b f)) (.forallE B F)) :
     LE_Interp ρ b.T B ∧ ∀ {{X x}}, LE_Interp ρ x.T X → LE_Interp ρ (f.app x).T (F.inst X) := by
@@ -4310,6 +7142,439 @@ theorem LE_Interp.lam_inv' {f : WShapeFun n} {hl : f.NonZero} {B F}
   rwa [SExpr.inst, SExpr.subst_lift', (?_ : Subst.lift_l _ _ = Subst.id), subst_id] at this
   funext i; cases i <;> rfl
 
+/-- Chosen data witnessing how application is transported along a lifted
+function-shape inclusion.  Packaging the choices in `Type` lets the
+proof-relevant interpreter retain them instead of eliminating `Exists`
+proofs into a witness. -/
+structure WShapeFun.AppLEData (f : WShapeFun n) (g : WShapeFun n') (x : WShape n) where
+  source : WShape n
+  source_le : source ≤ x
+  source_mem : (source, f.app x) ∈ f
+  input : WShape n'
+  output : WShape n'
+  mem : (input, output) ∈ g
+  input_le : input.lift (max n n') ≤ source.lift (max n n')
+  output_le : (f.app x).lift (max n n') ≤ output.lift (max n n')
+
+noncomputable def WShapeFun.appLEData (f : WShapeFun n) (g : WShapeFun n')
+    (x : WShape n) (hfg : f.lift (max n n') ≤ g.lift (max n n')) :
+    WShapeFun.AppLEData f g x := by
+  let hs := WShapeFun.app_eq f x
+  let source := hs.choose
+  have hs' := hs.choose_spec
+  have hsource_mem :
+      (source.lift (max n n'), (f.app x).lift (max n n')) ∈
+        f.lift (max n n') :=
+    (WShapeFun.mem_lift (Nat.le_max_left n n')).2
+      ⟨source, f.app x, hs'.2, rfl, rfl⟩
+  let ht := WShapeFun.LE.def'.1 hfg _ _ hsource_mem
+  let inputLift := ht.choose
+  let ht' := ht.choose_spec
+  let outputLift := ht'.choose
+  have ht'' := ht'.choose_spec
+  let hu := (WShapeFun.mem_lift (Nat.le_max_right n n')).1 ht''.1
+  let input := hu.choose
+  let hu' := hu.choose_spec
+  let output := hu'.choose
+  have hu'' := hu'.choose_spec
+  exact {
+    source
+    source_le := hs'.1
+    source_mem := hs'.2
+    input
+    output
+    mem := hu''.1
+    input_le := by rw [← hu''.2.1]; exact ht''.2.1
+    output_le := by rw [← hu''.2.2]; exact ht''.2.2
+  }
+
+/-- A chosen typed argument supplied by a function shape's domain proof. -/
+structure WShape.HasDomData (f : WShapeFun n) (a x : WShape n) where
+  arg : WShape n
+  arg_le : arg ≤ x
+  hasType : arg.HasType a
+  app_le : f.app x ≤ f.app arg
+
+noncomputable def WShape.HasDom.data {f : WShapeFun n} {a : WShape n}
+    (h : WShape.HasDom f a) (x : WShape n) : WShape.HasDomData f a x := by
+  let hx := WShape.HasDom.iff.1 h x
+  let arg := hx.choose
+  have hx' := hx.choose_spec
+  exact ⟨arg, hx'.1, hx'.2.1, hx'.2.2⟩
+
+/-- Proof-relevant Pi inversion.  The body callback is transported directly
+to the requested argument valuation, so recursive constant provenance below
+the binder is retained. -/
+noncomputable def LE_Interp.Witness.forallE_inv'
+    {b : WShape n} {f : WShapeFun n} {B F : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.forallE b f)) (.forallE B F)) :
+    LE_Interp.Witness ρ b.T B ×
+      ∀ x, LE_Interp.Witness (ρ.push x.T) (f.app x).T F := by
+  let .forallE (n := n') (f := f₁) hb _ hdom hbody hle := H
+  have le₁ := Nat.le_max_left n n'
+  have le₂ := Nat.le_max_right n n'
+  have ⟨hle_b, hle_f⟩ := TShape.LE.forallE_decomp hle
+  refine ⟨hb.mono ((TShape.LE.def le₁ le₂).2 hle_b), fun x => ?_⟩
+  let ha := WShapeFun.appLEData f f₁ x hle_f
+  let hd := WShape.HasDom.data hdom ha.input
+  have hinput : ha.input.T ≤ ha.source.T :=
+    (TShape.LE.def le₂ le₁).2 ha.input_le
+  have hout : (f.app x).T ≤ (f₁.app ha.input).T :=
+    ((TShape.LE.def le₁ le₂).2 ha.output_le).trans
+      (WShape.LE.T (WShapeFun.app_of_mem ha.mem).2)
+  exact (hbody hd.arg hd.hasType).mono_l
+      (Valuation.LE.push.2
+        ⟨.rfl, hd.arg_le.T.trans (hinput.trans ha.source_le.T)⟩)
+    |>.mono (WShape.LE.T hd.app_le)
+    |>.mono hout
+
+/-- Proof-relevant lambda inversion at one semantic argument. -/
+noncomputable def LE_Interp.Witness.lam_inv'
+    {f : WShapeFun n} {hl : f.NonZero} {B F : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (WShape.lam f hl)) (.lam B F))
+    (x : WShape n) :
+    LE_Interp.Witness (ρ.push x.T) (f.app x).T F := by
+  let .lam (n := n') (f := f₁) _ hdom hbody hle := H
+  have le₁ := Nat.le_max_left n n'
+  have le₂ := Nat.le_max_right n n'
+  have hle' := hle
+  rw [WShape.lam_eq_lam'] at hle'
+  have hle_f : f.lift (max n n') ≤ f₁.lift (max n n') :=
+    hle'.lam'_decomp
+  let ha := WShapeFun.appLEData f f₁ x hle_f
+  let hd := WShape.HasDom.data hdom ha.input
+  have hinput : ha.input.T ≤ ha.source.T :=
+    (TShape.LE.def le₂ le₁).2 ha.input_le
+  have hout : (f.app x).T ≤ (f₁.app ha.input).T :=
+    ((TShape.LE.def le₁ le₂).2 ha.output_le).trans
+      (WShape.LE.T (WShapeFun.app_of_mem ha.mem).2)
+  exact (hbody hd.arg hd.hasType).mono_l
+      (Valuation.LE.push.2
+        ⟨.rfl, hd.arg_le.T.trans (hinput.trans ha.source_le.T)⟩)
+    |>.mono (WShape.LE.T hd.app_le)
+    |>.mono hout
+
+/-- Proof-relevant Pi inversion together with the retained recursion trees
+of the selected domain and body observations.  The result stays in `Prop`:
+`RDeepChildren` is proof data, so eliminating it to choose a witness in
+`Type` would violate Lean's proof-irrelevance boundary. -/
+theorem LE_Interp.Witness.RDeepChildren.forallE_inv'
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    {b : WShape n} {f : WShapeFun n} {B F : SExpr}
+    {H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.forallE b f)) (.forallE B F)}
+    (children : H.RDeepChildren P) :
+    (∃ hB : LE_Interp.Witness ρ b.T B, hB.RDeepChildren P) ∧
+      ∀ x, ∃ hF : LE_Interp.Witness (ρ.push x.T) (f.app x).T F,
+        hF.RDeepChildren P := by
+  let .forallE (n := n') (b := b₁) (f := f₁)
+      hb hb' hdom hbody hle := H
+  cases children with
+  | forallE cb cb' cbody =>
+    have le₁ := Nat.le_max_left n n'
+    have le₂ := Nat.le_max_right n n'
+    obtain ⟨hle_b, hle_f⟩ := TShape.LE.forallE_decomp hle
+    have hbLe : b.T ≤ b₁.T := (TShape.LE.def le₁ le₂).2 hle_b
+    refine ⟨⟨hb.mono hbLe, cb.mono hbLe⟩, fun x => ?_⟩
+    let ha := WShapeFun.appLEData f f₁ x hle_f
+    let hd := WShape.HasDom.data hdom ha.input
+    have hinput : ha.input.T ≤ ha.source.T :=
+      (TShape.LE.def le₂ le₁).2 ha.input_le
+    have hout : (f.app x).T ≤ (f₁.app ha.input).T :=
+      ((TShape.LE.def le₁ le₂).2 ha.output_le).trans
+        (WShape.LE.T (WShapeFun.app_of_mem ha.mem).2)
+    let hFx := (hbody hd.arg hd.hasType).mono_l
+        (Valuation.LE.push.2
+          ⟨.rfl, hd.arg_le.T.trans (hinput.trans ha.source_le.T)⟩)
+      |>.mono (WShape.LE.T hd.app_le)
+      |>.mono hout
+    have cFx : hFx.RDeepChildren P :=
+      ((cbody hd.arg hd.hasType).mono_l hP
+          (Valuation.LE.push.2
+            ⟨.rfl, hd.arg_le.T.trans (hinput.trans ha.source_le.T)⟩))
+        |>.mono (WShape.LE.T hd.app_le)
+        |>.mono hout
+    exact ⟨hFx, cFx⟩
+
+/-- Lambda inversion with the exact retained body tree selected at each
+semantic argument. -/
+theorem LE_Interp.Witness.RDeepChildren.lam_inv'
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hP : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    {f : WShapeFun n} {hf : f.NonZero} {B F : SExpr}
+    {H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (WShape.lam f hf)) (.lam B F)}
+    (children : H.RDeepChildren P) :
+    ∀ x, ∃ hF : LE_Interp.Witness (ρ.push x.T) (f.app x).T F,
+      hF.RDeepChildren P := by
+  let .lam (n := n') (f := f₁) ha hdom hbody hle := H
+  cases children with
+  | lam ca cbody =>
+    have le₁ := Nat.le_max_left n n'
+    have le₂ := Nat.le_max_right n n'
+    have hle' := hle
+    rw [WShape.lam_eq_lam'] at hle'
+    have hle_f : f.lift (max n n') ≤ f₁.lift (max n n') :=
+      hle'.lam'_decomp
+    intro x
+    let haData := WShapeFun.appLEData f f₁ x hle_f
+    let hd := WShape.HasDom.data hdom haData.input
+    have hinput : haData.input.T ≤ haData.source.T :=
+      (TShape.LE.def le₂ le₁).2 haData.input_le
+    have hout : (f.app x).T ≤ (f₁.app haData.input).T :=
+      ((TShape.LE.def le₁ le₂).2 haData.output_le).trans
+        (WShape.LE.T (WShapeFun.app_of_mem haData.mem).2)
+    let hFx := (hbody hd.arg hd.hasType).mono_l
+        (Valuation.LE.push.2
+          ⟨.rfl, hd.arg_le.T.trans (hinput.trans haData.source_le.T)⟩)
+      |>.mono (WShape.LE.T hd.app_le)
+      |>.mono hout
+    have cFx : hFx.RDeepChildren P :=
+      ((cbody hd.arg hd.hasType).mono_l hP
+          (Valuation.LE.push.2
+            ⟨.rfl, hd.arg_le.T.trans (hinput.trans haData.source_le.T)⟩))
+        |>.mono (WShape.LE.T hd.app_le)
+        |>.mono hout
+    exact ⟨hFx, cFx⟩
+
+/-- Instantiate the body selected by proof-relevant Pi inversion.  This is
+the exact one-step operation used when a semantic fixed head follows its
+registered dependent application telescope. -/
+noncomputable def LE_Interp.Witness.forallE_inst
+    {b x : WShape n} {f : WShapeFun n} {B F X : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.forallE b f)) (.forallE B F))
+    (hX : LE_Interp.Witness ρ x.T X) :
+    LE_Interp.Witness ρ (f.app x).T (F.inst X) :=
+  (H.forallE_inv'.2 x).inst hX
+
+/-- Instantiate the body selected by proof-relevant lambda inversion. -/
+noncomputable def LE_Interp.Witness.lam_inst
+    {x : WShape n} {f : WShapeFun n} {hf : f.NonZero} {B F X : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.lam f hf)) (.lam B F))
+    (hX : LE_Interp.Witness ρ x.T X) :
+    LE_Interp.Witness ρ (f.app x).T (F.inst X) :=
+  (H.lam_inv' x).inst hX
+
+/-- Instantiate the exact Pi body while preserving both its retained tree
+and the argument's tree. -/
+theorem LE_Interp.Witness.RDeepChildren.forallE_inst
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hmono_l : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    (hclosed : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {b x : WShape n} {f : WShapeFun n} {B F X : SExpr}
+    {H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.forallE b f)) (.forallE B F)}
+    (children : H.RDeepChildren P)
+    {hX : LE_Interp.Witness ρ x.T X}
+    (childrenX : hX.RDeepChildren P) :
+    ∃ h : LE_Interp.Witness ρ (f.app x).T (F.inst X),
+      h.RDeepChildren P := by
+  obtain ⟨hbody, cbody⟩ := (children.forallE_inv' hmono_l).2 x
+  exact ⟨hbody.inst hX, cbody.inst hclosed childrenX⟩
+
+/-- Instantiate the exact lambda body while preserving both retained trees. -/
+theorem LE_Interp.Witness.RDeepChildren.lam_inst
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hmono_l : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    (hclosed : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    {x : WShape n} {f : WShapeFun n} {hf : f.NonZero}
+    {B F X : SExpr}
+    {H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (WShape.lam f hf)) (.lam B F)}
+    (children : H.RDeepChildren P)
+    {hX : LE_Interp.Witness ρ x.T X}
+    (childrenX : hX.RDeepChildren P) :
+    ∃ h : LE_Interp.Witness ρ (f.app x).T (F.inst X),
+      h.RDeepChildren P := by
+  obtain ⟨hbody, cbody⟩ := children.lam_inv' hmono_l x
+  exact ⟨hbody.inst hX, cbody.inst hclosed childrenX⟩
+
+theorem LE_Interp.Witness.forallE_inst_toInterp
+    {b x : WShape n} {f : WShapeFun n} {B F X : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.forallE b f)) (.forallE B F))
+    (hX : LE_Interp.Witness ρ x.T X) :
+    (H.forallE_inst hX).toInterp =
+      H.toInterp.forallE_inv.2 hX.toInterp :=
+  Subsingleton.elim _ _
+
+theorem LE_Interp.Witness.lam_inst_toInterp
+    {x : WShape n} {f : WShapeFun n} {hf : f.NonZero} {B F X : SExpr}
+    (H : LE_Interp.Witness ρ
+      (WShape.T (n := n + 1) (.lam f hf)) (.lam B F))
+    (hX : LE_Interp.Witness ρ x.T X) :
+    (H.lam_inst hX).toInterp =
+      (WShape.lam_eq_lam' ▸ H.toInterp).lam_inv hX.toInterp :=
+  Subsingleton.elim _ _
+
+/-- A typed interpretation whose term witness, type witness, and complete
+`R`-edge recursion trees remain synchronized.  This is the proof-relevant
+internal counterpart of `InterpTyped`; it lives in `Prop`, allowing exact
+witnesses to be unpacked only while proving semantic propositions. -/
+def LE_Interp.Witness.TypedRDeep
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (ρ : Valuation) (m : TShape) (M A : SExpr) : Prop :=
+  ∃ (m' a : TShape)
+      (hM : LE_Interp.Witness ρ m' M)
+      (hA : LE_Interp.Witness ρ a A),
+    m ≤ m' ∧ m'.HasType a ∧
+      hM.RDeepChildren P ∧ hA.RDeepChildren P
+
+/-- A retained witness enlarged to a semantic type observation. -/
+def LE_Interp.Witness.TypeRDeep
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (ρ : Valuation) (m : TShape) (M : SExpr) : Prop :=
+  ∃ (a : TShape) (hA : LE_Interp.Witness ρ a M),
+    m ≤ a ∧ a.HasType .type ∧ hA.RDeepChildren P
+
+/-- A retained typing at a syntactic sort supplies the type-shaped package
+needed by dependent application. -/
+theorem LE_Interp.Witness.TypedRDeep.toType
+    (H : LE_Interp.Witness.TypedRDeep P ρ m M (.sort U)) :
+    LE_Interp.Witness.TypeRDeep P ρ m M := by
+  obtain ⟨m', a, hM, hA, hle, hty, cM, _⟩ := H
+  exact ⟨m', hM, hle,
+    (TShape.HasType.mono_r hA.toInterp.le_sort .sort hty).toType, cM⟩
+
+/-- Bottom observations carry synchronized trivial term and type trees. -/
+theorem LE_Interp.Witness.TypedRDeep.bot
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hm : m ≤ TShape.bot) :
+    LE_Interp.Witness.TypedRDeep P ρ m M A := by
+  exact ⟨(WShape.bot (n := m.1)).T, (WShape.bot (n := m.1)).T,
+    .bot, .bot, hm.trans TShape.bot_eqv.2,
+    WShape.HasType.T (.bot' (.bot' .sort)), .bot, .bot⟩
+
+/-- Proof-relevant dependent application soundness.
+
+The function and result-type callbacks return exact witnesses together with
+their retained recursion trees.  Application itself introduces no new
+semantic `R` edge: it only lifts roots, performs exact Pi instantiation, and
+combines the already-retained function and argument trees. -/
+theorem LE_Interp.Witness.TypedRDeep.app
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (hmono_l : ∀ {ρ ρ' m M} (H : LE_Interp.Witness ρ m M)
+      (hρ : ρ.LE ρ'), P H → P (H.mono_l hρ))
+    (hclosed : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    (H1 : ∀ {m} (hF : LE_Interp.Witness ρ m F),
+      hF.RDeepChildren P →
+      LE_Interp.Witness.TypedRDeep P ρ m F (.forallE A B))
+    (H2 : ∀ {b} (hB : LE_Interp.Witness ρ b (B.inst X)),
+      hB.RDeepChildren P →
+      LE_Interp.Witness.TypeRDeep P ρ b (B.inst X))
+    {hApp : LE_Interp.Witness ρ m (F.app X)}
+    (children : hApp.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m (F.app X) (B.inst X) := by
+  by_cases hm : m ≤ .bot
+  · exact .bot hm
+  cases hApp with
+  | bot => exact (hm TShape.bot_eqv.1).elim
+  | @app _ nf fShape _ _ _ argShape hfun harg hroot =>
+    cases children with
+    | app cfun carg =>
+      obtain ⟨fShape', typeShape, hF, hPi, leF, htyped, cF, cPi⟩ :=
+        H1 hfun cfun
+      have hf : ¬fShape' ≤ .bot := fun h => by
+        rw [show fShape = .bot from TShape.le_bot.1 (leF.trans h),
+          WShape.bot_app] at hroot
+        exact hm (hroot.trans TShape.bot_le')
+      have hs : ¬typeShape ≤ .bot := fun h => hf (htyped.bot_r' h)
+      cases hPi with
+      | bot => exact (hs TShape.bot_le').elim
+      | forallE hDom hDom' hHasDom hBody hlePi =>
+        rename_i npi piDom piDom' piFun
+        cases cPi with
+        | forallE cDom cDom' cBody =>
+          cases hlePi.le_forall with
+          | bot hb => exact (hs hb).elim
+          | @forallE nType _ _ _ _ hDomLe hFunLe =>
+            obtain hbot | ⟨nFun, termFun, htermShape, hLamTy⟩ :=
+              htyped.ty_forallE_inv
+            · exact (hf (hbot ▸ TShape.LE.rfl)).elim
+            subst fShape'
+            let k := max (max nFun nType) (max npi nf)
+            have hk := Nat.max_le.1 (Nat.le_refl k)
+            simp only [Nat.max_le] at hk
+            have hPiRoot :
+                (WShape.T (n := k + 1)
+                  (.forallE (piDom.lift k) (piFun.lift k))) ≤
+                (WShape.T (n := npi + 1) (.forallE piDom piFun)) := by
+              have h :=
+                (TShape.lift_eqv (Nat.succ_le_succ hk.2.1)
+                  (a := (WShape.T (n := npi + 1)
+                    (.forallE piDom piFun)))).1
+              rw [WShape.lift_forallE hk.2.1] at h
+              exact h
+            let hPiK : LE_Interp.Witness ρ
+                (WShape.T (n := k + 1)
+                  (.forallE (piDom.lift k) (piFun.lift k)))
+                (.forallE A B) :=
+              .forallE hDom hDom' hHasDom hBody hPiRoot
+            have cPiK : hPiK.RDeepChildren P := by
+              exact .forallE cDom cDom' cBody
+            let hArgK := harg.mono (TShape.lift_eqv hk.2.2).1
+            have cArgK : hArgK.RDeepChildren P := carg.mono _
+            obtain ⟨hBinst, cBinst⟩ :=
+              cPiK.forallE_inst hmono_l hclosed cArgK
+            obtain ⟨resultType, hType, leType, hTypeType, cType⟩ :=
+              H2 hBinst cBinst
+            have hLamTy :=
+              (TShape.HasTypeLam.def hk.1.1 hk.1.2).1 hLamTy
+            have hLamDom := WShape.HasDom.iff.1 hLamTy.2.1
+            have ⟨_, hArgLe, hArgTy, hAppLe⟩ :=
+              hLamDom (argShape.lift k)
+            have hFuncRoot : (WShape.lam' (termFun.lift k)).T ≤
+                (WShape.lam' termFun).T := by
+              have h := (TShape.lift_eqv
+                (Nat.succ_le_succ hk.1.1)
+                (a := (WShape.lam' termFun).T)).1
+              rw [WShape.lift_lam' hk.1.1] at h
+              exact h
+            have hFuncUp : (WShape.lam' termFun).T ≤
+                (WShape.lam' (termFun.lift k)).T := by
+              have h := (TShape.lift_eqv
+                (Nat.succ_le_succ hk.1.1)
+                (a := (WShape.lam' termFun).T)).2
+              rw [WShape.lift_lam' hk.1.1] at h
+              exact h
+            let hFuncK := hF.mono hFuncRoot
+            have cFuncK : hFuncK.RDeepChildren P := cF.mono hFuncRoot
+            let hTerm : LE_Interp.Witness ρ
+                ((WShape.lam' (termFun.lift k)).app
+                  (argShape.lift k)).T (F.app X) :=
+              .app hFuncK hArgK .rfl
+            have cTerm : hTerm.RDeepChildren P := .app cFuncK cArgK
+            refine ⟨_, resultType, hTerm, hType, ?_, ?_, cTerm, cType⟩
+            · refine hroot.trans <| TShape.app_mono ?_
+                (TShape.lift_eqv hk.2.2).2
+              exact leF.trans hFuncUp
+            · have hFunLe :=
+                (TShapeFun.LE.def hk.1.2 hk.2.1).1 hFunLe
+              rw [WShape.lam'_app]
+              refine hTypeType.mono_r
+                ((WShapeFun.app_mono_l hFunLe _).trans
+                  (WShapeFun.app_mono_r hArgLe) |>.T.trans leType) ?_
+              exact (WShape.HasTypeLam.iff.1 hLamTy).2.2 _ hArgTy
+                |>.mono_l (WShapeFun.app_mono_r hArgLe) hAppLe |>.T
+
 inductive Valuation.Fits : (Γ Δ : List SExpr) → Valuation → Prop
   | nil : Valuation.Fits Γ Γ .nil
   | cons : Valuation.Fits Γ Δ ρ →
@@ -4320,6 +7585,14 @@ inductive Valuation.Fits : (Γ Δ : List SExpr) → Valuation → Prop
 def InterpTyped (ρ : Valuation) (m : TShape) (M A : SExpr) :=
   ∃ m' a, m ≤ m' ∧ LE_Interp ρ m' M ∧ LE_Interp ρ a A ∧ m'.HasType a
 
+/-- Forget retained recursion data and recover the public typed
+interpretation package. -/
+theorem LE_Interp.Witness.TypedRDeep.toInterpTyped
+    (H : LE_Interp.Witness.TypedRDeep P ρ m M A) :
+    InterpTyped ρ m M A := by
+  obtain ⟨m', a, hM, hA, hle, hty, _, _⟩ := H
+  exact ⟨m', a, hle, hM.toInterp, hA.toInterp, hty⟩
+
 theorem InterpTyped.bot : InterpTyped ρ (WShape.T (n := n) .bot) M A := by
   refine ⟨WShape.T (n := n) .bot, WShape.T (n := n) .bot, TShape.bot_le', .bot, .bot, ?_⟩
   exact WShape.HasType.T_iff.2 <| .bot' <| .bot' .sort
@@ -4353,6 +7626,822 @@ theorem LE_Interp.sound_bot :
     (LE_Interp ρ (WShape.T (n := n) .bot) M → InterpTyped ρ (WShape.T (n := n) .bot) M A) :=
   ⟨⟨fun _ => .bot, fun _ => .bot⟩, fun _ => .bot⟩
 
+structure LE_Interp.Witness.RDeepChildren.Laws
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop) : Prop
+    extends LE_Interp.Witness.RDeepChildren.JoinLaws P where
+  closed : ∀ {ρ ρ' : Valuation} {m M k}
+    (H : LE_Interp.Witness ρ m M)
+    (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+    P H → P (H.closed cl hρ)
+
+/-- The transport predicate used when retained semantic typing only needs the
+exact witness tree, while a separate consumer follows recursive `R` edges. -/
+theorem LE_Interp.Witness.RDeepChildren.Laws.true :
+    LE_Interp.Witness.RDeepChildren.Laws (fun _ => True) where
+  bot := trivial
+  mono := by intros; trivial
+  mono_l := by intros; trivial
+  join := by intros; trivial
+  closed := by intros; trivial
+
+/-- The free provenance-preserving transport closure of a recursive-result
+predicate.
+
+Semantic typing does not need the final consumer itself to be closed under
+joins and valuation changes.  It only needs to remember how a selected
+witness was obtained from an exact recursive `R` child.  This predicate
+records precisely those admissible operations.  Its `Laws` instance below
+is structural, so no consumer theorem is assumed while an enlarged or joined
+witness is being constructed. -/
+inductive LE_Interp.Witness.TransportClosure
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop) :
+    ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop where
+  | base {H : LE_Interp.Witness ρ m M} :
+      P H → TransportClosure P H
+  | bot : TransportClosure P
+      (LE_Interp.Witness.bot (ρ := ρ) (n := n) (M := M))
+  | mono {H : LE_Interp.Witness ρ m' M} (hle : m ≤ m') :
+      TransportClosure P H → TransportClosure P (H.mono hle)
+  | mono_l {H : LE_Interp.Witness ρ m M} (hρ : ρ.LE ρ') :
+      TransportClosure P H → TransportClosure P (H.mono_l hρ)
+  | join {H₁ : LE_Interp.Witness ρ m₁ M}
+      {H₂ : LE_Interp.Witness ρ m₂ M}
+      (HJ : LE_Interp.Witness ρ (m₁.join m₂) M) :
+      TransportClosure P H₁ → TransportClosure P H₂ →
+        TransportClosure P HJ
+  | closed {ρ' : Valuation} {H : LE_Interp.Witness ρ m M}
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i) :
+      TransportClosure P H → TransportClosure P (H.closed cl hρ)
+
+/-- The transport closure is the free `RDeepChildren.Laws` algebra over
+`P`.  In particular, `P` itself need not provide a join law. -/
+theorem LE_Interp.Witness.TransportClosure.laws :
+    LE_Interp.Witness.RDeepChildren.Laws
+      (LE_Interp.Witness.TransportClosure P) where
+  bot := .bot
+  mono := fun _ hle h => .mono hle h
+  mono_l := fun _ hρ h => .mono_l hρ h
+  join := fun _ _ HJ h₁ h₂ => .join HJ h₁ h₂
+  closed := fun _ cl hρ h => .closed cl hρ h
+
+/-- Anchor every exact recursive `R` result in the free transport closure
+without changing the retained evaluator tree. -/
+theorem LE_Interp.Witness.RDeepChildren.toTransportClosure
+    {H : LE_Interp.Witness ρ m M}
+    (children : H.RDeepChildren P) :
+    H.RDeepChildren (LE_Interp.Witness.TransportClosure P) :=
+  children.map (fun _ h => .base h)
+
+/-- Structural semantic recursion whose step receives transport-stable
+provenance rather than demanding transport laws from its final consumer.
+
+This is the evaluator-coherent replacement for threading a consumer result
+unchanged through `recNatRDeep`: actual `R` children are marked by `base`,
+and every later semantic enlargement records its derivation in
+`TransportClosure`. -/
+theorem LE_Interp.Witness.recRDeepTransport
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (step : ∀ {ρ m M} (H : LE_Interp.Witness ρ m M),
+      H.RDeepChildren (LE_Interp.Witness.TransportClosure P) → P H)
+    {ρ m M} (H : LE_Interp.Witness ρ m M) : P H := by
+  apply H.recRDeep
+  intro ρ m M H children
+  exact step H children.toTransportClosure
+
+/-- Semantic-first recursion with provenance-checked Nat restarts.
+
+Genuine evaluator `R` edges receive the result at every Nat index by
+structural descent through the exact witness.  A strictly smaller Nat index
+may restart at another witness only when the caller supplies a complete tree
+whose recursive edges are traced back to those genuine results through
+`TransportClosure`.  Thus root/valuation/closed/instantiation/join transports
+remain available without admitting an unrelated same-index restart. -/
+theorem LE_Interp.Witness.recRDeepNatTransport
+    {Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren
+        (LE_Interp.Witness.TransportClosure (fun hM' => ∀ d, Q hM' d)) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρ m M} (hM' : LE_Interp.Witness ρ m M),
+          hM'.RDeepChildren
+            (LE_Interp.Witness.TransportClosure
+              (fun hM'' => ∀ d, Q hM'' d)) →
+          Q hM' d') →
+      Q hM d)
+    {ρ m M} (hM : LE_Interp.Witness ρ m M) : ∀ d, Q hM d := by
+  let P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop :=
+    fun hM => ∀ d, Q hM d
+  apply hM.recRDeepTransport (P := P)
+  intro ρ m M hM children
+  let motive := fun d =>
+    ∀ {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren
+        (LE_Interp.Witness.TransportClosure P) → Q hM d
+  have go : ∀ d, motive d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρ m M hM children
+      exact step d hM children
+        (fun d' hd' {_ _ _} hM' children' =>
+          ih d' hd' hM' children')
+  exact fun d => go d hM children
+
+/-- The inspectable recursive seed available at one Nat index.
+
+The left injection is reserved for a genuine semantic `R` child and carries
+its structurally recursive result at every index.  The right injection is a
+local seed at exactly `d`; it is what a strictly-smaller syntax derivation may
+attach after rebuilding a freshly selected witness's evaluator tree. -/
+abbrev LE_Interp.Witness.NatSeed
+    (Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop)
+    (d : Nat) {ρ m M} (H : LE_Interp.Witness ρ m M) : Prop :=
+  (∀ k, Q H k) ∨ Q H d
+
+/-- Free semantic transport closure over a depth-local recursive seed.
+
+This predicate is used inside retained semantic typing, where root,
+valuation, closed-term, and compatible-join transports must be recorded.
+The outer consumer algebra receives `NatSeed` instead, so it can inspect why
+an actual evaluator edge is justified without assuming that the final
+consumer is closed under every semantic transport. -/
+abbrev LE_Interp.Witness.NatProvenance
+    (Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop)
+    (d : Nat) {ρ m M} (H : LE_Interp.Witness ρ m M) : Prop :=
+  LE_Interp.Witness.TransportClosure
+    (LE_Interp.Witness.NatSeed Q d) H
+
+/-- Semantic-first/Nat-second recursion with depth-local provenance.
+
+Every actual evaluator edge is injected on the all-depth side of `NatSeed`.
+At a strict Nat decrease, a restarted witness may instead
+carry local seeds at that smaller index.  This is the guarded form needed by
+conversion: folding a definition may point a new constant edge at the
+current witness, but it can attach only the result already obtained from the
+smaller endpoint derivation, never the all-depth result under construction. -/
+theorem LE_Interp.Witness.recRDeepNatProvenance
+    {Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop}
+    (step : ∀ (d : Nat)
+        {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (LE_Interp.Witness.NatSeed Q d) →
+      (∀ (d' : Nat), d' < d →
+        ∀ {ρ m M} (hM' : LE_Interp.Witness ρ m M),
+          hM'.RDeepChildren
+            (LE_Interp.Witness.NatSeed Q d') →
+          Q hM' d') →
+      Q hM d)
+    {ρ m M} (hM : LE_Interp.Witness ρ m M) : ∀ d, Q hM d := by
+  let P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop :=
+    fun hM => ∀ d, Q hM d
+  apply hM.recRDeep (P := P)
+  intro ρ m M hM children
+  let motive := fun d =>
+    ∀ {ρ m M} (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (LE_Interp.Witness.NatSeed Q d) →
+        Q hM d
+  have go : ∀ d, motive d := by
+    intro d
+    induction d using Nat.strongRecOn with
+    | ind d ih =>
+      intro ρ m M hM childrenAt
+      exact step d hM childrenAt
+        (fun d' hd' {_ _ _} hM' children' =>
+          ih d' hd' hM' children')
+  exact fun d => go d hM
+    (children.map (fun _ h => .inl h))
+
+/-- Every exact witness retains its complete constructor tree when recursive
+`R` edges carry no additional consumer data. -/
+theorem LE_Interp.Witness.RDeepChildren.trivial
+    (H : LE_Interp.Witness ρ m M) :
+    H.RDeepChildren (fun _ => True) := by
+  induction H with
+  | bot => exact .bot
+  | bvar => exact .bvar
+  | sort => exact .sort
+  | app _ _ _ ihf iha => exact .app ihf iha
+  | lam _ _ _ _ iha ihbody => exact .lam iha ihbody
+  | forallE _ _ _ _ _ ihb ihb' ihbody =>
+    exact .forallE ihb ihb' ihbody
+  | const _ _ _ _ _ _ _ ihA ihR =>
+    exact .const ihA (fun _ _ _ => True.intro) ihR
+
+noncomputable def LE_Interp.Witness.RDeepChildren.choose
+    (H : ∃ h : LE_Interp.Witness ρ m M, h.RDeepChildren P) :
+    {h : LE_Interp.Witness ρ m M // h.RDeepChildren P} :=
+  Classical.choice (by
+    obtain ⟨h, ch⟩ := H
+    exact ⟨⟨h, ch⟩⟩)
+
+theorem LE_Interp.Witness.TypedRDeep.mono
+    (hle : m ≤ m')
+    (H : LE_Interp.Witness.TypedRDeep P ρ m' M A) :
+    LE_Interp.Witness.TypedRDeep P ρ m M A := by
+  obtain ⟨mm, aa, hM, hA, hm, hty, cM, cA⟩ := H
+  exact ⟨mm, aa, hM, hA, hle.trans hm, hty, cM, cA⟩
+
+theorem LE_Interp.Witness.TypedRDeep.weak
+    (hclosed : ∀ {ρ ρ' : Valuation} {m M k}
+      (H : LE_Interp.Witness ρ m M)
+      (cl : ClosedN M k) (hρ : ∀ i < k, ρ i = ρ' i),
+      P H → P (H.closed cl hρ))
+    (H : LE_Interp.Witness.TypedRDeep P ρ m M A) :
+    LE_Interp.Witness.TypedRDeep P (ρ.push x) m M.lift A.lift := by
+  obtain ⟨mm, aa, hM, hA, hm, hty, cM, cA⟩ := H
+  exact ⟨mm, aa, hM.weak, hA.weak, hm, hty,
+    cM.weak hclosed, cA.weak hclosed⟩
+
+theorem LE_Interp.Witness.TypedRDeep.out
+    (H : LE_Interp.Witness.TypedRDeep P ρ m M A) :
+    ∃ n', ∃ m' a' : WShape n', ∃
+        (hM : LE_Interp.Witness ρ m'.T M)
+        (hA : LE_Interp.Witness ρ a'.T A),
+      m.1 ≤ n' ∧ m ≤ m'.T ∧ m'.HasType a' ∧
+        hM.RDeepChildren P ∧ hA.RDeepChildren P := by
+  obtain ⟨m', a', hM, hA, hm, hty, cM, cA⟩ := H
+  let k := max m.1 (max m'.1 a'.1)
+  have hk := Nat.max_le.1 (Nat.le_refl k)
+  simp only [Nat.max_le] at hk
+  let mw := m'.2.lift k
+  let aw := a'.2.lift k
+  let hMk := hM.mono (TShape.lift_eqv hk.2.1).1
+  let hAk := hA.mono (TShape.lift_eqv hk.2.2).1
+  exact ⟨k, mw, aw, hMk, hAk, hk.1,
+    hm.trans (TShape.lift_eqv hk.2.1).2,
+    (TShape.HasType.def hk.2.1 hk.2.2).1 hty,
+    cM.mono _, cA.mono _⟩
+
+/-- Proof-relevant lambda soundness with every recursive constant edge
+retained in both the term family and its dependent result-type family. -/
+theorem LE_Interp.Witness.TypedRDeep.lam
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (H2 : ∀ {a x} (hA : LE_Interp.Witness ρ a A),
+      hA.RDeepChildren P → x.HasType a →
+      ∀ {e} (hF : LE_Interp.Witness (ρ.push x) e F),
+        hF.RDeepChildren P →
+        LE_Interp.Witness.TypedRDeep P (ρ.push x) e F B)
+    {hLam : LE_Interp.Witness ρ m (A.lam F)}
+    (children : hLam.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m (A.lam F) (A.forallE B) := by
+  by_cases hm : m ≤ .bot
+  · exact .bot hm
+  cases hLam with
+  | bot => exact (hm TShape.bot_eqv.1).elim
+  | @lam _ n a _ f _ _ hA hdom hbody hroot =>
+    cases children with
+    | lam cA cbody =>
+      suffices ∀ (fl : List (WShape n × WShape n)),
+          (∀ p ∈ fl, p ∈ f ∧
+            ∃ h : LE_Interp.Witness (ρ.push p.1.T) p.2.T F,
+              h.RDeepChildren P) →
+          ∃ n', n ≤ n' ∧ ∀ k, n' ≤ k →
+            ∃ f' b : WShapeFun k,
+              (∀ p ∈ fl,
+                WShapeFun.single (p.1.lift k) (p.2.lift k) ≤ f') ∧
+              WShape.HasDom f' (a.lift k) ∧
+              WShape.HasDom b (a.lift k) ∧
+              (∀ x, x.HasType (a.lift k) →
+                ∃ h : LE_Interp.Witness (ρ.push x.T) (f'.app x).T F,
+                  h.RDeepChildren P) ∧
+              (∀ x, x.HasType (a.lift k) →
+                ∃ h : LE_Interp.Witness (ρ.push x.T) (b.app x).T B,
+                  h.RDeepChildren P) ∧
+              (∀ x, x.HasType (a.lift k) →
+                (f'.app x).HasType (b.app x)) by
+        have hElems : ∀ p ∈ f.elems, p ∈ f ∧
+            ∃ h : LE_Interp.Witness (ρ.push p.1.T) p.2.T F,
+              h.RDeepChildren P := by
+          intro p hp
+          have hpMem := WShapeFun.mem_elems.1 hp
+          have ⟨x', hxle, hxty, happ⟩ := WShape.HasDom.iff.1 hdom p.1
+          let hFx := (hbody x' hxty).mono_l
+              (Valuation.LE.push.2 ⟨.rfl, hxle.T⟩)
+            |>.mono ((WShapeFun.app_of_mem hpMem).2.trans happ).T
+          have cFx : hFx.RDeepChildren P :=
+            ((cbody x' hxty).mono_l laws.mono_l
+                (Valuation.LE.push.2 ⟨.rfl, hxle.T⟩))
+              |>.mono ((WShapeFun.app_of_mem hpMem).2.trans happ).T
+          exact ⟨hpMem, hFx, cFx⟩
+        obtain ⟨n', le, build⟩ := this f.elems hElems
+        obtain ⟨f', b, hsingle, hd1, hd2, hi1, hi2, hi3⟩ :=
+          build _ (Nat.le_refl _)
+        let hAK := hA.mono (TShape.lift_eqv le).1
+        have cAK : hAK.RDeepChildren P := cA.mono _
+        let bodyTerm := fun x hx =>
+          (LE_Interp.Witness.RDeepChildren.choose (hi1 x hx)).1
+        let bodyType := fun x hx =>
+          (LE_Interp.Witness.RDeepChildren.choose (hi2 x hx)).1
+        have htermRoot : m ≤ (WShape.lam' f').T := by
+          refine hroot.trans <|
+            (TShape.LE.lift_l (Nat.succ_le_succ le)).2
+              (WShape.lift_lam' le ▸ ?_)
+          refine WShape.lam'_le_lam'.2 <|
+            WShapeFun.LE.def'.2 fun x y hxy => ?_
+          obtain ⟨x₀, y₀, h₀, rfl, rfl⟩ :=
+            (WShapeFun.mem_lift le).1 hxy
+          exact WShapeFun.single_le.1
+            (hsingle _ (WShapeFun.mem_elems.2 h₀))
+        let hTerm : LE_Interp.Witness ρ (WShape.lam' f').T (A.lam F) :=
+          .lam hAK hd1 bodyTerm .rfl
+        let hType : LE_Interp.Witness ρ
+            ((a.lift n').forallE b).T (A.forallE B) :=
+          .forallE hAK hAK hd2 bodyType .rfl
+        have cTerm : hTerm.RDeepChildren P :=
+          .lam cAK (fun x hx =>
+            (LE_Interp.Witness.RDeepChildren.choose (hi1 x hx)).2)
+        have cType : hType.RDeepChildren P :=
+          .forallE cAK cAK (fun x hx =>
+            (LE_Interp.Witness.RDeepChildren.choose (hi2 x hx)).2)
+        exact ⟨_, _, hTerm, hType, htermRoot,
+          WShape.HasType.T <| .lam <| WShape.HasTypeLam.iff.2
+            ⟨WShape.HasTypePi.iff.2
+                ⟨hd2, fun x hx => (hi3 x hx).isType⟩,
+              hd1, hi3⟩,
+          cTerm, cType⟩
+      intro fl Hfl
+      induction fl with
+      | nil =>
+        refine ⟨n, Nat.le_refl _, fun k hk => ?_⟩
+        have ha : (a.lift k).HasType .type :=
+          WShape.lift_type.symm ▸
+            (WShape.HasType.lift hk).2 hdom.isType
+        refine ⟨.bot, .bot, nofun, .bot ha, .bot ha,
+          fun x hx => ?_,
+          fun x hx => ?_,
+          fun x hx => ?_⟩
+        · rw [WShapeFun.bot_app]
+          exact ⟨.bot, .bot⟩
+        · rw [WShapeFun.bot_app]
+          exact ⟨.bot, .bot⟩
+        simp [WShapeFun.bot_app]
+        exact .bot' (.bot' .sort)
+      | cons p fl ih =>
+        have ⟨⟨hpMem, hpBody⟩, Htail⟩ :=
+          List.forall_mem_cons.1 Hfl
+        have ⟨k₁, le1, H1⟩ := ih Htail
+        obtain ⟨x', x'le, hx', happ⟩ :=
+          WShape.HasDom.iff.1 hdom p.1
+        obtain ⟨hp, cp⟩ := hpBody
+        obtain ⟨nBody, e', b', he', hb', leBody, le_e,
+          heb', ce', cb'⟩ :=
+          (H2 hA cA (WShape.HasType.T hx')
+            (hbody x' hx') (cbody x' hx')).out
+        refine ⟨max k₁ nBody,
+          Nat.le_trans le1 (Nat.le_max_left ..),
+          fun k le' => ?_⟩
+        have ⟨le₁, le₂⟩ := Nat.max_le.1 le'
+        have le_nk : n ≤ k := Nat.le_trans le1 le₁
+        have le_ek := le₂
+        have le_bk := le₂
+        obtain ⟨f₁, b₁, hsingle₁, hd1₁, hd2₁,
+          hi1₁, hi2₁, hi3₁⟩ := H1 _ le₁
+        let sf := WShapeFun.single (x'.lift k) (e'.lift k)
+        let sb := WShapeFun.single (x'.lift k) (b'.lift k)
+        have hi1Any z : ∃ h : LE_Interp.Witness
+            (ρ.push z.T) (f₁.app z).T F, h.RDeepChildren P := by
+          obtain ⟨z', z'le, z'ht, z'app⟩ :=
+            WShape.HasDom.iff.1 hd1₁ z
+          obtain ⟨hz, cz⟩ := hi1₁ z' z'ht
+          let hz' := hz.mono z'app.T |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)
+          exact ⟨hz', (cz.mono z'app.T).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)⟩
+        have hi2Any z : ∃ h : LE_Interp.Witness
+            (ρ.push z.T) (b₁.app z).T B, h.RDeepChildren P := by
+          obtain ⟨z', z'le, z'ht, z'app⟩ :=
+            WShape.HasDom.iff.1 hd2₁ z
+          obtain ⟨hz, cz⟩ := hi2₁ z' z'ht
+          let hz' := hz.mono z'app.T |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)
+          exact ⟨hz', (cz.mono z'app.T).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)⟩
+        have hxLift : x'.T ≤ (x'.lift k).T := by
+          apply (TShape.LE.lift_l (a := x'.T)
+            (b := (x'.lift k).T) le_nk).2
+          exact WShape.LE.rfl
+        let heK : LE_Interp.Witness (ρ.push (x'.lift k).T)
+            (e'.lift k).T F :=
+          he'.mono (TShape.lift_eqv le_ek).1 |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        have ceK : heK.RDeepChildren P :=
+          (ce'.mono (TShape.lift_eqv le_ek).1).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        let hbK : LE_Interp.Witness (ρ.push (x'.lift k).T)
+            (b'.lift k).T B :=
+          hb'.mono (TShape.lift_eqv le_bk).1 |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        have cbK : hbK.RDeepChildren P :=
+          (cb'.mono (TShape.lift_eqv le_bk).1).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        have hc : f₁.Compat sf := by
+          rw [WShapeFun.compat_single]
+          intro ⟨xj, yj⟩ hmem hc
+          obtain ⟨z, hz1, hz2⟩ := WShape.Compat.iff.1 hc
+          have sfApp : sf.app z = e'.lift k := by
+            rw [WShapeFun.single_app, if_pos hz2]
+          obtain ⟨hz, _⟩ := hi1Any z
+          exact .mono
+            ((WShapeFun.app_of_mem hmem).2.trans
+              (WShapeFun.app_mono_r hz1))
+            (sfApp ▸ WShape.LE.rfl) <|
+            WShape.Compat.T_iff.2 <|
+              hz.toInterp.compat
+                (sfApp ▸ heK.toInterp.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, hz2.T⟩))
+        have hcb : b₁.Compat sb := by
+          rw [WShapeFun.compat_single]
+          intro ⟨xj, yj⟩ hmem hc
+          obtain ⟨z, hz1, hz2⟩ := WShape.Compat.iff.1 hc
+          have sbApp : sb.app z = b'.lift k := by
+            rw [WShapeFun.single_app, if_pos hz2]
+          obtain ⟨hz, _⟩ := hi2Any z
+          exact .mono
+            ((WShapeFun.app_of_mem hmem).2.trans
+              (WShapeFun.app_mono_r hz1))
+            (sbApp ▸ WShape.LE.rfl) <|
+            WShape.Compat.T_iff.2 <|
+              hz.toInterp.compat
+                (sbApp ▸ hbK.toInterp.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, hz2.T⟩))
+        have jf := WShapeFun.Join.mk hc
+        have jb := WShapeFun.Join.mk hcb
+        refine ⟨f₁.join sf, b₁.join sb, ?_, ?_, ?_,
+          fun x hx => ?_, fun x hx => ?_, fun x hx => ?_⟩
+        · refine List.forall_mem_cons.2 ⟨?_, fun r hr =>
+            (hsingle₁ r hr).trans jf.le.1⟩
+          refine (WShapeFun.single_le.2
+            ⟨_, _, WShapeFun.mem_single.2 (.inl rfl), ?_, ?_⟩).trans
+              jf.le.2
+          · exact WShape.lift_mono le_nk x'le
+          · exact WShape.lift_mono le_nk
+              ((WShapeFun.app_of_mem hpMem).2.trans happ)
+              |>.trans ((TShape.LE.def le_nk le_ek).1 le_e)
+        · refine hd1₁.join' ?_ jf (WShape.join_self.2 ⟨.rfl, .rfl⟩)
+          exact WShape.HasDom.single.2 <|
+            .inl <| (WShape.HasType.lift le_nk).2 hx'
+        · refine hd2₁.join' ?_ jb (WShape.join_self.2 ⟨.rfl, .rfl⟩)
+          exact WShape.HasDom.single.2 <|
+            .inl <| (WShape.HasType.lift le_nk).2 hx'
+        · obtain ⟨hz, cz⟩ := hi1Any x
+          have hs : ∃ h : LE_Interp.Witness
+              (ρ.push x.T) (sf.app x).T F, h.RDeepChildren P := by
+            dsimp only [sf]
+            by_cases hmatch : x'.lift k ≤ x
+            · rw [WShapeFun.single_app, if_pos hmatch]
+              exact ⟨heK.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩),
+                ceK.mono_l laws.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩)⟩
+            · rw [WShapeFun.single_app, if_neg hmatch]
+              exact ⟨.bot, .bot⟩
+          obtain ⟨hs, cs⟩ := hs
+          obtain ⟨_, joined⟩ := cz.compat_join laws.toJoinLaws
+            .rfl cs
+          have hJ := LE_Interp.Witness.RDeepChildren.choose joined
+          have jx := jf.app_l x
+          have hcRoot : (f₁.app x).T.Compat (sf.app x).T :=
+            WShape.Compat.T_iff.1 jx.compat
+          have jxT : TShape.Join (f₁.app x).T (sf.app x).T
+              ((f₁.join sf).app x).T := jx.T
+          have hin : ((f₁.join sf).app x).T ≤
+              (f₁.app x).T.join (sf.app x).T :=
+            (jxT _).2 (TShape.Join.mk hcRoot).le
+          exact ⟨hJ.1.mono hin, hJ.2.mono hin⟩
+        · obtain ⟨hz, cz⟩ := hi2Any x
+          have hs : ∃ h : LE_Interp.Witness
+              (ρ.push x.T) (sb.app x).T B, h.RDeepChildren P := by
+            dsimp only [sb]
+            by_cases hmatch : x'.lift k ≤ x
+            · rw [WShapeFun.single_app, if_pos hmatch]
+              exact ⟨hbK.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩),
+                cbK.mono_l laws.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩)⟩
+            · rw [WShapeFun.single_app, if_neg hmatch]
+              exact ⟨.bot, .bot⟩
+          obtain ⟨hs, cs⟩ := hs
+          obtain ⟨_, joined⟩ := cz.compat_join laws.toJoinLaws
+            .rfl cs
+          have hJ := LE_Interp.Witness.RDeepChildren.choose joined
+          have jx := jb.app_l x
+          have hcRoot : (b₁.app x).T.Compat (sb.app x).T :=
+            WShape.Compat.T_iff.1 jx.compat
+          have jxT : TShape.Join (b₁.app x).T (sb.app x).T
+              ((b₁.join sb).app x).T := jx.T
+          have hin : ((b₁.join sb).app x).T ≤
+              (b₁.app x).T.join (sb.app x).T :=
+            (jxT _).2 (TShape.Join.mk hcRoot).le
+          exact ⟨hJ.1.mono hin, hJ.2.mono hin⟩
+        · have hT1 := hi3₁ x hx
+          have hT2 : (sf.app x).HasType (sb.app x) := by
+            rw [WShapeFun.single_app, WShapeFun.single_app]
+            split
+            · exact (WShape.HasType.lift le₂).2 heb'
+            · exact .bot' (.bot' .sort)
+          have jbx := jb.app_l x
+          have hJT := hT1.isType.join' jbx hT2.isType
+          exact (hJT.mono_r jbx.le.1 hT1).join' (jf.app_l x)
+            (hJT.mono_r jbx.le.2 hT2)
+
+/-- Proof-relevant dependent-function type soundness.  The observed body
+family is saturated while retaining the exact witness selected at every
+point, and the two domain observations in the input witness are joined
+without discarding either recursive tree. -/
+theorem LE_Interp.Witness.TypedRDeep.forallE
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (H1 : ∀ {a} (hA : LE_Interp.Witness ρ a A),
+      hA.RDeepChildren P →
+      LE_Interp.Witness.TypedRDeep P ρ a A (.sort u))
+    (H2 : ∀ {a x} (hA : LE_Interp.Witness ρ a A),
+      hA.RDeepChildren P → x.HasType a →
+      ∀ {e} (hB : LE_Interp.Witness (ρ.push x) e B),
+        hB.RDeepChildren P →
+        LE_Interp.Witness.TypedRDeep P (ρ.push x) e B (.sort v))
+    {hPi : LE_Interp.Witness ρ m (A.forallE B)}
+    (children : hPi.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m (A.forallE B)
+      (.sort (.imax u v)) := by
+  by_cases hm : m ≤ .bot
+  · exact .bot hm
+  cases hPi with
+  | bot => exact (hm TShape.bot_eqv.1).elim
+  | @forallE _ n b₀ _ b f _ _ hb₀ hb hdom hbody hroot =>
+    cases children with
+    | forallE cb₀ cb cbody =>
+      suffices ∀ (fl : List (WShape n × WShape n)),
+          (∀ p ∈ fl, p ∈ f ∧
+            ∃ h : LE_Interp.Witness (ρ.push p.1.T) p.2.T B,
+              h.RDeepChildren P) →
+          ∃ n', n ≤ n' ∧ ∀ k, n' ≤ k →
+            ∃ f' : WShapeFun k,
+              (∀ p ∈ fl,
+                WShapeFun.single (p.1.lift k) (p.2.lift k) ≤ f') ∧
+              WShape.HasDom f' (b.lift k) ∧
+              (∀ x, x.HasType (b.lift k) →
+                ∃ h : LE_Interp.Witness (ρ.push x.T) (f'.app x).T B,
+                  h.RDeepChildren P) ∧
+              (∀ x, x.HasType (b.lift k) →
+                (f'.app x).HasType (.sort (v ≠ .zero))) by
+        have hElems : ∀ p ∈ f.elems, p ∈ f ∧
+            ∃ h : LE_Interp.Witness (ρ.push p.1.T) p.2.T B,
+              h.RDeepChildren P := by
+          intro p hp
+          have hpMem := WShapeFun.mem_elems.1 hp
+          obtain ⟨x', hxle, hxty, happ⟩ :=
+            WShape.HasDom.iff.1 hdom p.1
+          let hBx := (hbody x' hxty).mono
+              ((WShapeFun.app_of_mem hpMem).2.trans happ).T
+            |>.mono_l (Valuation.LE.push.2 ⟨.rfl, hxle.T⟩)
+          have cBx : hBx.RDeepChildren P :=
+            ((cbody x' hxty).mono
+                ((WShapeFun.app_of_mem hpMem).2.trans happ).T)
+              |>.mono_l laws.mono_l
+                (Valuation.LE.push.2 ⟨.rfl, hxle.T⟩)
+          exact ⟨hpMem, hBx, cBx⟩
+        obtain ⟨n', le, build⟩ := this f.elems hElems
+        obtain ⟨f', hsingle, hd1, hi1, hi2⟩ :=
+          build _ (Nat.le_refl _)
+        obtain ⟨hcompat, joinedDom⟩ :=
+          cb₀.compat_join laws.toJoinLaws .rfl cb
+        have hDomJ := LE_Interp.Witness.RDeepChildren.choose joinedDom
+        obtain ⟨b₂, s₂, hB₂, hS₂, hDomLe, hB₂Ty,
+          cB₂, cS₂⟩ := H1 hDomJ.1 hDomJ.2
+        have hB₂Sort : b₂.HasType (TShape.sort (u ≠ .zero)) :=
+          TShape.HasType.mono_r hS₂.toInterp.le_sort .sort hB₂Ty
+        let k := max n' b₂.1
+        have ⟨le₂, le₁⟩ := Nat.max_le.1 (Nat.le_refl k)
+        have hdK₀ := (WShape.HasDom.lift le₂).2 hd1
+        have hdK : WShape.HasDom (f'.lift k) (b.lift k) :=
+          WShape.lift_lift (.inl le) ▸ hdK₀
+        have hB₂Le : (b₂.2.lift k).T ≤ b₂ :=
+          (TShape.lift_eqv le₁).1
+        let hB₂K : LE_Interp.Witness ρ (b₂.2.lift k).T A :=
+          hB₂.mono hB₂Le
+        have cB₂K : hB₂K.RDeepChildren P := by
+          dsimp only [hB₂K]
+          exact cB₂.mono hB₂Le
+        have hBLe : (b.lift k).T ≤ b.T :=
+          (TShape.lift_eqv (Nat.le_trans le le₂)).1
+        let hBK : LE_Interp.Witness ρ (b.lift k).T A :=
+          hb.mono hBLe
+        have cBK : hBK.RDeepChildren P := by
+          dsimp only [hBK]
+          exact cb.mono hBLe
+        have bodyK (x : WShape k) (hx : x.HasType (b.lift k)) :
+            ∃ h : LE_Interp.Witness (ρ.push x.T)
+                ((f'.lift k).app x).T B,
+              h.RDeepChildren P := by
+          obtain ⟨x', xle, xmem⟩ := (f'.lift k).app_eq x
+          obtain ⟨z₀, -, -, rfl, -⟩ :=
+            (WShapeFun.mem_lift le₂).1 xmem
+          obtain ⟨z', zle, zty, zapp⟩ :=
+            WShape.HasDom.iff.1 hd1 z₀
+          obtain ⟨hz, cz⟩ := hi1 z' zty
+          have hρz : (ρ.push z'.T).LE
+              (ρ.push (z₀.lift k).T) := by
+            refine Valuation.LE.push.2 ⟨.rfl, ?_⟩
+            exact zle.T.trans (TShape.lift_eqv le₂).2
+          have hzKPair : ∃ h : LE_Interp.Witness
+              (ρ.push (z₀.lift k).T)
+                ((f'.lift k).app (z₀.lift k)).T B,
+              h.RDeepChildren P := by
+            let hz₀ := (hz.mono zapp.T |>.mono_l hρz).mono
+              (TShape.lift_eqv le₂).1
+            have hz₀Pair : ∃ h : LE_Interp.Witness
+                (ρ.push (z₀.lift k).T)
+                  ((f'.app z₀).lift k).T B,
+                h.RDeepChildren P := ⟨hz₀, by
+              dsimp only [hz₀]
+              exact ((cz.mono zapp.T).mono_l laws.mono_l hρz).mono
+                (TShape.lift_eqv le₂).1⟩
+            exact WShapeFun.lift_app le₂ ▸ hz₀Pair
+          obtain ⟨hzK, czK⟩ := hzKPair
+          let hzX := hzK.mono_l <|
+            Valuation.LE.push.2 ⟨.rfl, xle.T⟩
+          have czX : hzX.RDeepChildren P := by
+            dsimp only [hzX]
+            exact czK.mono_l laws.mono_l <|
+              Valuation.LE.push.2 ⟨.rfl, xle.T⟩
+          have hApp := (WShapeFun.app_of_mem xmem).2.T
+          exact ⟨hzX.mono hApp, czX.mono hApp⟩
+        let hBody := fun x hx =>
+          (LE_Interp.Witness.RDeepChildren.choose (bodyK x hx)).1
+        let hTerm : LE_Interp.Witness ρ
+            ((b₂.2.lift k).forallE (f'.lift k)).T
+            (A.forallE B) :=
+          .forallE hB₂K hBK hdK hBody .rfl
+        let hType : LE_Interp.Witness ρ
+            (TShape.sort (u.imax v ≠ .zero))
+            (.sort (u.imax v)) :=
+          .sort TShape.LE.rfl
+        have cTerm : hTerm.RDeepChildren P :=
+          .forallE cB₂K cBK (fun x hx =>
+            (LE_Interp.Witness.RDeepChildren.choose (bodyK x hx)).2)
+        have cType : hType.RDeepChildren P := .sort
+        have hroot' : m ≤
+            ((b₂.2.lift k).forallE (f'.lift k)).T := by
+          refine hroot.trans ?_
+          rw [TShape.LE.lift_l
+            (Nat.succ_le_succ (Nat.le_trans le le₂)),
+            WShape.lift_forallE (Nat.le_trans le le₂)]
+          refine WShape.forallE_le_forallE.2 ⟨?_, ?_⟩
+          · exact (TShape.LE.def (Nat.le_trans le le₂) le₁).1 <|
+              (TShape.Join.mk hcompat).le.1.trans hDomLe
+          · rw [← WShapeFun.lift_lift (.inl le)]
+            refine WShapeFun.lift_mono le₂ <|
+              WShapeFun.LE.def'.2 fun x y hxy => ?_
+            obtain ⟨x₀, y₀, h₀, rfl, rfl⟩ :=
+              (WShapeFun.mem_lift le).1 hxy
+            exact WShapeFun.single_le.1 <|
+              hsingle _ (WShapeFun.mem_elems.2 h₀)
+        have hTyped : ((b₂.2.lift k).forallE (f'.lift k)).T.HasType
+            (TShape.sort (u.imax v ≠ .zero)) := by
+          apply (TShape.HasType.def (Nat.le_refl _)
+            (Nat.zero_le _)).2
+          simp only [WShape.lift_self, TShape.sort, WShape.lift_sort, ne_eq,
+            SLevel.imax_eq_zero]
+          have hB₂SortK :=
+            (TShape.HasType.def le₁ (Nat.zero_le k)).1 hB₂Sort
+          refine .forallE <| WShape.HasTypePi.iff.2
+            ⟨hdK.mono_r ?_ hB₂SortK, fun x hx => ?_⟩
+          · exact (TShape.LE.def (Nat.le_trans le le₂) le₁).1 <|
+              (TShape.Join.mk hcompat).le.2.trans hDomLe
+          · obtain ⟨x', _, xmem⟩ := (f'.lift k).app_eq x
+            obtain ⟨x₀, y₀, hm, rfl, heq⟩ :=
+              (WShapeFun.mem_lift le₂).1 xmem
+            have ⟨appLe, appEq⟩ := WShapeFun.app_of_mem hm
+            refine heq ▸ WShape.lift_sort.symm ▸
+              (WShape.HasType.lift le₂).2 (.mono_l appLe appEq ?_)
+            obtain ⟨y, yle, yty, yapp⟩ :=
+              WShape.HasDom.iff.1 hd1 x₀
+            exact (hi2 _ yty).mono_l
+              (WShapeFun.app_mono_r yle) yapp
+        exact ⟨_, _, hTerm, hType, hroot', hTyped, cTerm, cType⟩
+      intro fl Hfl
+      induction fl with
+      | nil =>
+        refine ⟨n, Nat.le_refl _, fun k hk => ?_⟩
+        have hbTy : (b.lift k).HasType .type := by
+          simpa [WShape.lift_sort] using
+            (WShape.HasType.lift hk).2 hdom.isType
+        refine ⟨.bot, nofun, .bot hbTy, fun x hx => ?_,
+          fun x hx => ?_⟩
+        · rw [WShapeFun.bot_app]
+          exact ⟨.bot, .bot⟩
+        · simp [WShapeFun.bot_app]
+          exact .bot' .sort
+      | cons p fl ih =>
+        have ⟨⟨hpMem, hpBody⟩, Htail⟩ :=
+          List.forall_mem_cons.1 Hfl
+        obtain ⟨k₁, le1, H1'⟩ := ih Htail
+        obtain ⟨x', x'le, hx', happ⟩ :=
+          WShape.HasDom.iff.1 hdom p.1
+        obtain ⟨nBody, e', s', he', hs', leBody, le_e,
+          heTy, ce', cs'⟩ :=
+          (H2 hb cb (WShape.HasType.T hx')
+            (hbody x' hx') (cbody x' hx')).out
+        have heSortT : e'.T.HasType (TShape.sort (v ≠ .zero)) :=
+          TShape.HasType.mono_r hs'.toInterp.le_sort .sort heTy.T
+        have heSort : e'.HasType (.sort (v ≠ .zero)) := by
+          simpa only [TShape.sort, WShape.lift_sort,
+            WShape.lift_self] using
+            (TShape.HasType.def (Nat.le_refl nBody)
+              (Nat.zero_le nBody)).1 heSortT
+        refine ⟨max k₁ nBody,
+          Nat.le_trans le1 (Nat.le_max_left ..), fun k le' => ?_⟩
+        have ⟨le₁, le₂⟩ := Nat.max_le.1 le'
+        have le_nk : n ≤ k := Nat.le_trans le1 le₁
+        obtain ⟨f₁, hsingle₁, hd1₁, hi1₁, hi2₁⟩ :=
+          H1' _ le₁
+        let sf := WShapeFun.single (x'.lift k) (e'.lift k)
+        have hi1Any z : ∃ h : LE_Interp.Witness
+            (ρ.push z.T) (f₁.app z).T B, h.RDeepChildren P := by
+          obtain ⟨z', z'le, z'ty, z'app⟩ :=
+            WShape.HasDom.iff.1 hd1₁ z
+          obtain ⟨hz, cz⟩ := hi1₁ z' z'ty
+          let hz' := hz.mono z'app.T |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)
+          exact ⟨hz', (cz.mono z'app.T).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, z'le.T⟩)⟩
+        have hxLift : x'.T ≤ (x'.lift k).T := by
+          apply (TShape.LE.lift_l (a := x'.T)
+            (b := (x'.lift k).T) le_nk).2
+          exact WShape.LE.rfl
+        let heK : LE_Interp.Witness (ρ.push (x'.lift k).T)
+            (e'.lift k).T B :=
+          he'.mono (TShape.lift_eqv le₂).1 |>.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        have ceK : heK.RDeepChildren P :=
+          (ce'.mono (TShape.lift_eqv le₂).1).mono_l laws.mono_l
+            (Valuation.LE.push.2 ⟨.rfl, hxLift⟩)
+        have hc : f₁.Compat sf := by
+          rw [WShapeFun.compat_single]
+          intro ⟨xj, yj⟩ hmem hc
+          obtain ⟨z, hz1, hz2⟩ := WShape.Compat.iff.1 hc
+          have sfApp : sf.app z = e'.lift k := by
+            rw [WShapeFun.single_app, if_pos hz2]
+          obtain ⟨hz, _⟩ := hi1Any z
+          exact .mono
+            ((WShapeFun.app_of_mem hmem).2.trans
+              (WShapeFun.app_mono_r hz1))
+            (sfApp ▸ WShape.LE.rfl) <|
+            WShape.Compat.T_iff.2 <|
+              hz.toInterp.compat
+                (sfApp ▸ heK.toInterp.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, hz2.T⟩))
+        have jf := WShapeFun.Join.mk hc
+        refine ⟨f₁.join sf, ?_, ?_, fun x hx => ?_,
+          fun x hx => ?_⟩
+        · refine List.forall_mem_cons.2 ⟨?_, fun r hr =>
+            (hsingle₁ r hr).trans jf.le.1⟩
+          refine (WShapeFun.single_le.2
+            ⟨_, _, WShapeFun.mem_single.2 (.inl rfl), ?_, ?_⟩).trans
+              jf.le.2
+          · exact WShape.lift_mono le_nk x'le
+          · exact WShape.lift_mono le_nk
+              ((WShapeFun.app_of_mem hpMem).2.trans happ)
+              |>.trans ((TShape.LE.def le_nk le₂).1 le_e)
+        · refine hd1₁.join' ?_ jf
+            (WShape.join_self.2 ⟨.rfl, .rfl⟩)
+          exact WShape.HasDom.single.2 <|
+            .inl <| (WShape.HasType.lift le_nk).2 hx'
+        · obtain ⟨hz, cz⟩ := hi1Any x
+          have hs : ∃ h : LE_Interp.Witness
+              (ρ.push x.T) (sf.app x).T B, h.RDeepChildren P := by
+            dsimp only [sf]
+            by_cases hmatch : x'.lift k ≤ x
+            · rw [WShapeFun.single_app, if_pos hmatch]
+              exact ⟨heK.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩),
+                ceK.mono_l laws.mono_l
+                  (Valuation.LE.push.2 ⟨.rfl, WShape.LE.T hmatch⟩)⟩
+            · rw [WShapeFun.single_app, if_neg hmatch]
+              exact ⟨.bot, .bot⟩
+          obtain ⟨hs, cs⟩ := hs
+          obtain ⟨_, joined⟩ := cz.compat_join laws.toJoinLaws
+            .rfl cs
+          have hJ := LE_Interp.Witness.RDeepChildren.choose joined
+          have jx := jf.app_l x
+          have hcRoot : (f₁.app x).T.Compat (sf.app x).T :=
+            WShape.Compat.T_iff.1 jx.compat
+          have jxT : TShape.Join (f₁.app x).T (sf.app x).T
+              ((f₁.join sf).app x).T := jx.T
+          have hin : ((f₁.join sf).app x).T ≤
+              (f₁.app x).T.join (sf.app x).T :=
+            (jxT _).2 (TShape.Join.mk hcRoot).le
+          exact ⟨hJ.1.mono hin, hJ.2.mono hin⟩
+        · have hT1 := hi2₁ x hx
+          have hT2 : (sf.app x).HasType
+              (.sort (v ≠ .zero)) := by
+            dsimp only [sf]
+            rw [WShapeFun.single_app]
+            split
+            · simpa only [WShape.lift_sort] using
+                (WShape.HasType.lift le₂).2 heSort
+            · exact .bot' .sort
+          exact hT1.join' (jf.app_l x) hT2
+
 theorem LE_Interp.sound_app
     (H1 : ∀ {m}, LE_Interp ρ m F → InterpTyped ρ m F (.forallE A B))
     (H2 : ∀ {b}, LE_Interp ρ b (B.inst X) →
@@ -4611,9 +8700,9 @@ inductive StrongSoundCore : List SExpr → SExpr → SExpr → Prop where
     StrongSound (A::Γ) e B → StrongSoundCore Γ (.lam A e) (.forallE A B)
   | const : Params.env.constants c = some ci → ls.length = ci.uvars →
     (F : ∀ cl, CtorBundle c cl) →
-    (∀ cl, SoundEq Γ ((SExpr.mk ci.type).instL ls) ((F cl).rhs ls)) →
+    (∀ cl, SoundEq Γ (SExpr.mkInst ls ci.type) ((F cl).rhs ls)) →
     (∀ cl, StrongSound Γ ((F cl).rhs ls) (.sort (F cl).u)) →
-    StrongSoundCore Γ (.const c ls) ((SExpr.mk ci.type).instL ls)
+    StrongSoundCore Γ (.const c ls) (SExpr.mkInst ls ci.type)
   | app : SoundTy Γ A (.sort u) →
     StrongSound Γ f (.forallE A B) → StrongSound Γ a A →
     StrongSoundCore Γ (.app f a) (B.inst a)
@@ -4751,9 +8840,91 @@ theorem StrongSound.uniq : StrongSound Γ M A → StrongSound Γ M B → SoundEq
     simp only [SoundEq.sort, ne_eq, SLevel.imax_eq_zero]
     exact SoundEq.sort.1 (ihB a2 b2)
 
+/-- Data-bearing view of the constant case of `StrongSound`.  The view is
+chosen classically so proof-relevant consumers do not eliminate a `Prop`
+derivation directly into `Type`. -/
+structure StrongSound.ConstView
+    {Γ : List SExpr} {c : Name} {ls : List SLevel} {T : SExpr}
+    (H : StrongSound Γ (.const c ls) T) where
+  ci : VConstant
+  hreg : Params.env.constants c = some ci
+  hlen : ls.length = ci.uvars
+  resultEq : SoundEq Γ (SExpr.mkInst ls ci.type) T
+
+theorem StrongSound.constViewNonempty
+    (H : StrongSound Γ (.const c ls) T) : Nonempty H.ConstView := by
+  obtain ⟨_, _, hcore, heq⟩ := H
+  cases hcore with
+  | const hreg hlen _ _ _ => exact ⟨⟨_, hreg, hlen, heq⟩⟩
+
+noncomputable def StrongSound.constView
+    (H : StrongSound Γ (.const c ls) T) : H.ConstView :=
+  Classical.choice H.constViewNonempty
+
+/-- Data-bearing view of the application case of `StrongSound`. -/
+structure StrongSound.AppView
+    {Γ : List SExpr} {f a T : SExpr}
+    (H : StrongSound Γ (.app f a) T) where
+  dom : SExpr
+  cod : SExpr
+  funType : StrongSound Γ f (.forallE dom cod)
+  argType : StrongSound Γ a dom
+  resultEq : SoundEq Γ (cod.inst a) T
+
+theorem StrongSound.appViewNonempty
+    (H : StrongSound Γ (.app f a) T) : Nonempty H.AppView := by
+  obtain ⟨_, _, hcore, heq⟩ := H
+  cases hcore with
+  | app _ hfun harg => exact ⟨⟨_, _, hfun, harg, heq⟩⟩
+
+noncomputable def StrongSound.appView
+    (H : StrongSound Γ (.app f a) T) : H.AppView :=
+  Classical.choice H.appViewNonempty
+
+/-- A data-bearing witness for semantic instantiation. -/
+structure LE_Interp.InstView
+    {ρ : Valuation} {m : TShape} {F A : SExpr}
+    (H : LE_Interp ρ m (F.inst A)) where
+  arg : TShape
+  body : LE_Interp (ρ.push arg) m F
+  value : LE_Interp ρ arg A
+
+theorem LE_Interp.instViewNonempty
+    {ρ : Valuation} {m : TShape} {F A : SExpr}
+    (H : LE_Interp ρ m (F.inst A)) : Nonempty H.InstView := by
+  obtain ⟨arg, hbody, hvalue⟩ := LE_Interp.inst.1 H
+  exact ⟨⟨arg, hbody, hvalue⟩⟩
+
+noncomputable def LE_Interp.instView
+    {ρ : Valuation} {m : TShape} {F A : SExpr}
+    (H : LE_Interp ρ m (F.inst A)) : H.InstView :=
+  Classical.choice H.instViewNonempty
+
+/-- Data-bearing form of `InterpTyped.out` for proof-relevant builders. -/
+structure InterpTyped.OutView
+    {ρ : Valuation} {m : TShape} {M A : SExpr}
+    (H : InterpTyped ρ m M A) where
+  level : Nat
+  termShape : WShape level
+  typeShape : WShape level
+  rootLevel_le : m.1 ≤ level
+  root_le : m ≤ termShape.T
+  termInterp : LE_Interp ρ termShape.T M
+  typeInterp : LE_Interp ρ typeShape.T A
+  typed : termShape.HasType typeShape
+
+theorem InterpTyped.outViewNonempty
+    (H : InterpTyped ρ m M A) : Nonempty H.OutView := by
+  obtain ⟨level, termShape, typeShape, hlevel, hle, hterm, htype, htyped⟩ := H.out
+  exact ⟨⟨level, termShape, typeShape, hlevel, hle, hterm, htype, htyped⟩⟩
+
+noncomputable def InterpTyped.outView
+    (H : InterpTyped ρ m M A) : H.OutView :=
+  Classical.choice H.outViewNonempty
+
 theorem LE_Interp.apps_realize_inv (W : Valuation.Fits Γ₀ Γ ρ)
     (h_env : Params.env.constants c = some ci)
-    (h_intr_defeq : SoundEq Γ ((SExpr.mk ci.type).instL ls) (List.foldr .forallE body Ts))
+    (h_intr_defeq : SoundEq Γ (SExpr.mkInst ls ci.type) (List.foldr .forallE body Ts))
     (h_k_eq : List.length srev + k = Ts.length)
     (hTy : StrongSound Γ (srev.foldr (fun A acc => acc.app A) (.const c ls)) T)
     (H : LE_Interp (srev.length.repeat (·.push .bot) ρ) m
@@ -4778,17 +8949,27 @@ theorem LE_Interp.apps_realize_inv (W : Valuation.Fits Γ₀ Γ ρ)
     · intro x hx; cases hx.bot_r; simp [WShapeFun.single_app]
       exact H.mono_l <| Valuation.LE.push.2 ⟨.rfl, TShape.bot_eqv.2⟩
 
-theorem LE_Interp.apps_realize (W : Valuation.Fits Γ₀ Γ ρ)
+/-- Realize a typed constant application through an explicitly selected
+evaluator relation.
+
+Unlike `apps_realize` below, this theorem does not replace the relation
+stored by the constant with the proof-irrelevant ambient interpretation.
+The caller supplies both the exact relation and its realization callback,
+so a later proof-relevant consumer can retain the evaluator edge that was
+actually used to build the constant. -/
+theorem LE_Interp.apps_realizeWith (W : Valuation.Fits Γ₀ Γ ρ)
     (mty : m'.HasType a) (ha : LE_Interp ρ a T)
     (hTy_lhs : StrongSound Γ (rAs.foldr (fun A acc => acc.app A) (.const c ls)) T)
     (hargs : List.Forall₂ (LE_Interp ρ ·.T) (rargs : List (WShape n)) rAs)
-    (hC : Const c ls (LE_Interp ρ) rargs m') :
+    (hC : Const c ls R rargs m')
+    (hR : ∀ m e, R m e → LE_Interp ρ m e)
+    (hRmono : ∀ {m m' e}, m ≤ m' → R m' e → R m e) :
     LE_Interp ρ m' (rAs.foldr (fun A acc => acc.app A) (.const c ls)) := by
   generalize h_len : rargs.length = k
   induction k generalizing m' a T rAs n with | succ k ih => ?_ | zero =>
     let .nil := hargs
     have ⟨_, _, hTy, hType⟩ := hTy_lhs; have .const h1 h2 .. := hTy
-    exact .const h1 h2 .rfl mty ((hType W).2 ha) hC fun _ _ => id
+    exact .const h1 h2 .rfl mty ((hType W).2 ha) hC hR
   let .cons (a := arg) (b := A) (l₁ := rest_r) (l₂ := rest_s) h_arg h_rest := hargs
   cases h_len
   have ⟨_, _, hTy, hC_inst⟩ := hTy_lhs; have .app _ hMf hMa := hTy
@@ -4824,8 +9005,163 @@ theorem LE_Interp.apps_realize (W : Valuation.Fits Γ₀ Γ ρ)
   · exact List.forall₂_map_left_iff.2 <| h_rest.imp fun _ _ h => h.mono (TShape.lift_eqv hk.1.1).1
   · refine Const.lam (fun x y hmem => ?_) .rfl
     obtain ⟨⟨⟩⟩ | ⟨_, ⟨⟩⟩ := WShapeFun.mem_single.1 hmem <;> [skip; exact .bot]
-    refine hC.lift hk.1.1 .mono |>.mono_l ?_ |>.mono (TShape.lift_eqv hk.1.2).1 .mono
-    exact .cons ((TShape.LE.def hk.1.1 hk.2.1).1 (hJ.le.1.trans jle)) <| .rfl fun _ _ => .rfl
+    have hClift : Const c ls R ((arg :: rest_r).map (.lift k)) m' :=
+      hC.lift hk.1.1 hRmono
+    have hargsLe : ((arg :: rest_r).map (.lift k)).Forall₂ (· ≤ ·)
+        (arg'' :: rest_r.map (.lift k)) :=
+      .cons ((TShape.LE.def hk.1.1 hk.2.1).1
+        (hJ.le.1.trans jle)) <| .rfl fun _ _ => .rfl
+    have hCargs : Const c ls R (arg'' :: rest_r.map (.lift k)) m' :=
+      hClift.mono_l hargsLe
+    exact hCargs.mono (TShape.lift_eqv hk.1.2).1 hRmono
+
+/-- Proof-relevant realization of a typed constant application through an
+explicit evaluator relation.
+
+The returned `Witness` is assembled directly.  In particular, its constant
+node stores `hC` and `hR` literally; it is never recovered from the public
+`LE_Interp` proposition by `LE_Interp.witness`.  Ordinary argument and type
+observations may still be chosen noncomputably, but the evaluator edge whose
+provenance drives recursive unfolding remains the caller's exact witness. -/
+noncomputable def LE_Interp.Witness.appsRealizeWith
+    (W : Valuation.Fits Γ₀ Γ ρ)
+    (mty : m'.HasType a) (ha : LE_Interp.Witness ρ a T)
+    (hTy_lhs : StrongSound Γ
+      (rAs.foldr (fun A acc => acc.app A) (.const c ls)) T)
+    (hargs : List.Forall₂ (LE_Interp ρ ·.T)
+      (rargs : List (WShape n)) rAs)
+    (hC : Const c ls R rargs m')
+    (hR : ∀ m e, R m e → LE_Interp.Witness ρ m e)
+    (hRmono : ∀ {m m' e}, m ≤ m' → R m' e → R m e) :
+    LE_Interp.Witness ρ m'
+      (rAs.foldr (fun A acc => acc.app A) (.const c ls)) := by
+  generalize h_len : rargs.length = k
+  induction k generalizing m' a T rAs n with
+  | zero =>
+    have hrargs : rargs = [] := List.eq_nil_of_length_eq_zero h_len
+    have hrAs : rAs = [] := List.eq_nil_of_length_eq_zero
+      (hargs.length_eq.symm.trans h_len)
+    subst rargs
+    subst rAs
+    let hview := hTy_lhs.constView
+    let hTypeWitness := ((hview.resultEq W).2 ha.toInterp).witness
+    exact .const hview.hreg hview.hlen .rfl mty hTypeWitness hC hR
+  | succ k ih =>
+    cases rargs with
+    | nil => simp at h_len
+    | cons arg rest_r =>
+      cases rAs with
+      | nil => simp at hargs
+      | cons A rest_s =>
+       have h_arg := (List.forall₂_cons.1 hargs).1
+       have h_rest := (List.forall₂_cons.1 hargs).2
+       have hrest_len : rest_r.length = k := by simpa using h_len
+       let hTyView := hTy_lhs.appView
+       let hInst := ((hTyView.resultEq W).2 ha.toInterp).instView
+       let y := hInst.arg
+       have hya := hInst.body
+       have hy := hInst.value
+       let hTyped := (hTyView.argType.sound W (h_arg.join' hy)).outView
+       let n' := hTyped.level
+       let arg' := hTyped.termShape
+       let aT := hTyped.typeShape
+       have jle := hTyped.root_le
+       have h_LE := hTyped.termInterp
+       have ha' := hTyped.typeInterp
+       have harg' := hTyped.typed
+       let depth := max (max n m'.1) (max n' a.1)
+       have hk := Nat.max_le.1 (Nat.le_refl depth)
+       simp only [Nat.max_le] at hk
+       let arg'' := arg'.lift depth
+       let m'' := m'.2.lift depth
+       let m2 : WShape (depth + 1) := .lam' (.single arg'' m'')
+       suffices hrest : LE_Interp.Witness ρ m2.T
+           (rest_s.foldr (fun A acc => acc.app A) (.const c ls)) by
+         let hargWitness : LE_Interp.Witness ρ arg''.T A :=
+           (h_LE.lift hk.2.1).witness
+         have happ := LE_Interp.Witness.app hrest hargWitness
+           (TShape.LE.rfl : (m2.app arg'').T ≤ (m2.app arg'').T)
+         simp only [m2, WShape.lam'_app, WShapeFun.single_app,
+           WShape.LE.rfl, ↓reduceIte] at happ
+         exact happ.mono (TShape.lift_eqv hk.1.2).2
+       have hJ := TShape.Join.mk (h_arg.compat hy)
+       let aT' := aT.lift depth
+       let a' := a.2.lift depth
+       let a2 : WShape (depth + 1) := .forallE aT' (.single arg'' a')
+       have h_argw_typed : arg''.HasType aT' :=
+         (WShape.HasType.lift hk.2.1).2 harg'
+       let ha2Interp : LE_Interp ρ a2.T
+           (.forallE hTyView.dom hTyView.cod) := by
+         refine .forallE' (ha'.lift hk.2.1) (ha'.lift hk.2.1)
+           (WShape.HasDom.single.2 (.inl h_argw_typed)) fun x _ => ?_
+         rw [WShapeFun.single_app]
+         split <;> [rename_i h1; exact .bot]
+         refine .lift hk.2.2 <| hya.mono_l
+           (Valuation.LE.push.2 ⟨.rfl, ?_⟩)
+         exact (hJ.le.2.trans jle).trans
+           (TShape.lift_eqv hk.2.1).2 |>.trans h1.T
+       let ha2 : LE_Interp.Witness ρ a2.T
+           (.forallE hTyView.dom hTyView.cod) := ha2Interp.witness
+       refine ih (a := a2.T) (rargs := rest_r.map (.lift depth))
+           (m' := m2.T) ?_ ha2 hTyView.funType ?_ ?_ ?_
+       · have h_m_typed := (TShape.HasType.def hk.1.2 hk.2.2).1 mty
+         refine WShape.HasType.T <| .lam <|
+           WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+         · refine WShape.HasTypePi.def.2
+             ⟨WShape.HasDom.single.2 (.inl h_argw_typed), fun x y h => ?_⟩
+           obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ :=
+             WShapeFun.mem_single.1 h
+           · exact h_m_typed.isType
+           · exact .bot' .sort
+         · exact WShape.HasDom.single.2 (.inl h_argw_typed)
+         · simp only [WShapeFun.single_app]
+           split <;> [exact h_m_typed; exact .bot' (.bot' .sort)]
+       · exact List.forall₂_map_left_iff.2 <|
+           h_rest.imp fun _ _ h => h.mono (TShape.lift_eqv hk.1.1).1
+       · refine Const.lam (fun x y hmem => ?_) .rfl
+         obtain ⟨⟨⟩⟩ | ⟨_, ⟨⟩⟩ := WShapeFun.mem_single.1 hmem <;>
+           [skip; exact .bot]
+         have hClift : Const c ls R ((arg :: rest_r).map (.lift depth)) m' :=
+           hC.lift hk.1.1 hRmono
+         have hargsLe : ((arg :: rest_r).map (.lift depth)).Forall₂ (· ≤ ·)
+             (arg'' :: rest_r.map (.lift depth)) :=
+           .cons ((TShape.LE.def hk.1.1 hk.2.1).1
+             (hJ.le.1.trans jle)) <| .rfl fun _ _ => .rfl
+         have hCargs : Const c ls R
+             (arg'' :: rest_r.map (.lift depth)) m' :=
+           hClift.mono_l hargsLe
+         exact hCargs.mono (TShape.lift_eqv hk.1.2).1 hRmono
+       · simpa using hrest_len
+
+/-- Realize a constant application with the singleton evaluator relation
+generated by one exact RHS witness.  Every evaluator edge stored in the
+result is therefore a root lowering of `hX`, never an ambient re-selection. -/
+noncomputable def LE_Interp.Witness.appsRealizeFocused
+    (W : Valuation.Fits Γ₀ Γ ρ)
+    (mty : m'.HasType a) (ha : LE_Interp.Witness ρ a T)
+    (hTy_lhs : StrongSound Γ
+      (rAs.foldr (fun A acc => acc.app A) (.const c ls)) T)
+    (hargs : List.Forall₂ (LE_Interp ρ ·.T)
+      (rargs : List (WShape n)) rAs)
+    (hX : LE_Interp.Witness ρ root X)
+    (hC : Const c ls hX.LowerEdge rargs m') :
+    LE_Interp.Witness ρ m'
+      (rAs.foldr (fun A acc => acc.app A) (.const c ls)) :=
+  LE_Interp.Witness.appsRealizeWith W mty ha hTy_lhs hargs hC
+    (fun _ _ edge => edge.realize)
+    (fun hle edge => edge.mono hle)
+
+/-- Compatibility form of `apps_realizeWith` using every ambient semantic
+interpretation as a possible evaluator edge.  Proof-relevant conversion
+producers should call `apps_realizeWith` directly with a focused relation. -/
+theorem LE_Interp.apps_realize (W : Valuation.Fits Γ₀ Γ ρ)
+    (mty : m'.HasType a) (ha : LE_Interp ρ a T)
+    (hTy_lhs : StrongSound Γ (rAs.foldr (fun A acc => acc.app A) (.const c ls)) T)
+    (hargs : List.Forall₂ (LE_Interp ρ ·.T) (rargs : List (WShape n)) rAs)
+    (hC : Const c ls (LE_Interp ρ) rargs m') :
+    LE_Interp ρ m' (rAs.foldr (fun A acc => acc.app A) (.const c ls)) :=
+  LE_Interp.apps_realizeWith W mty ha hTy_lhs hargs hC
+    (fun _ _ h => h) (fun hle h => h.mono hle)
 
 theorem LE_Interp.RHS.le_applyS
     (hpath : ∀ path, LE_Interp ρ (m1 path) (m2 path))
@@ -5000,7 +9336,7 @@ theorem LE_Interp.build_spine {m1 : p.Path → TShape} {m2} (a2 : p.MatchesS LHS
         ∃ ci, Params.env.constants c_a = some ci ∧ f2.length = ci.uvars ∧ ∃ I Ts args u,
           Ts.length = rargs_a.length ∧ Params.classify I = some (.indTy args.length) ∧ u ≠ .zero ∧
           let e := List.foldr .forallE (List.foldr (fun A acc => acc.app A) (.const I f2) args) Ts
-          SoundEq Γ ((SExpr.mk ci.type).instL f2) e ∧ StrongSound Γ e (.sort u) := by
+          SoundEq Γ (SExpr.mkInst f2 ci.type) e ∧ StrongSound Γ e (.sort u) := by
       clear forall2_a hTy_f hTy_a foldr_eq_a hB
       induction As generalizing B with have ⟨_, _, hTy, _⟩ := hTy_at_foldr
       | nil =>
@@ -5041,8 +9377,216 @@ theorem LE_Interp.build_spine {m1 : p.Path → TShape} {m2} (a2 : p.MatchesS LHS
         Const.indTy (rargs := .replicate args.length .bot) (List.length_replicate ▸ hI) .rfl
           |>.lift k'.le_succ .mono
 
-theorem LE_Interp.strongSound (H : Γ ⊢ M ≡ N : A) : StrongSoundEq Γ M N A := by
-  replace H := H.strong
+/-- The proof-relevant payload retained while reversing one generated iota
+action.
+
+The public equality only says that the instantiated RHS and the matched
+redex have the same interpretations.  That is insufficient for recursive
+consumers: rebuilding the redex through the ambient `LE_Interp` relation may
+select a different witness for the registered fixed head.  This certificate
+instead stores the literal head sub-witness peeled from `hRhs`, the ordered
+semantic capture spine, and the constant evaluator whose recursive relation
+is exactly `headWitness.LowerEdge`.
+
+The certificate also retains the exact stratified typing of the applied RHS
+and the native typing exposed for its literal fixed head.  The
+derivation-aware conversion caller still supplies the semantic type witness
+used to realize the redex below; retaining the syntax derivations here keeps
+the later guarded producer from reselecting either endpoint. -/
+structure _root_.Lean4Lean.Pattern.IotaRule.FocusedActionPreimage
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r)
+    {Gamma : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {A : SExpr} {rho : Valuation} {out : TShape}
+    (action : Pattern.Action Gamma r e ls capture A)
+    (hRhs : LE_Interp.Witness rho out (r.1.applyS ls capture))
+    (rhsDepth : Nat) where
+  rhsStratified : HasTypeStratifiedS Gamma
+    (r.1.applyS ls capture) A true rhsDepth
+  headType : SExpr
+  headStratified : HasTypeStratifiedS Gamma
+    (SExpr.mkInst ls rule.df.rhs) headType true
+      (rhsDepth - rule.capturePaths.length)
+  mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape
+  captureInterp : ∀ path, LE_Interp rho (mcap path) (capture path)
+  head : TShape
+  headWitness : LE_Interp.Witness rho head
+    (SExpr.mkInst ls rule.df.rhs)
+  spine : LE_Interp.RHS.ShapeSpine
+    mcap head rule.capturePaths out
+  argLevel : Nat
+  constantName : Name
+  args : List (WShape argLevel)
+  matchedCapture :
+    (RecursorIotaPattern rec major ctor arity).Path → TShape
+  argExprs : List SExpr
+  matched : LE_Interp.Matches
+    (RecursorIotaPattern rec major ctor arity)
+    constantName args matchedCapture
+  capture_le : ∀ path, mcap path ≤ matchedCapture path
+  argsInterp : List.Forall₂ (LE_Interp rho ·.T) args argExprs
+  lhs_eq :
+    argExprs.foldr (fun arg fn => fn.app arg)
+      (.const constantName ls) = e
+  constantInterp : LE_Interp.Const constantName ls
+    headWitness.LowerEdge args out
+
+/-- Reverse a generated iota action without broadening its fixed-head
+evaluator edge.
+
+`focusedShapeSpine` first peels the exact RHS witness.  `build_spine` then
+reconstructs only the matched constant/argument prefix, and `focusedRHS`
+installs root lowerings of that same head witness as the constant's abstract
+evaluator relation.  No proof-independent call to `RHS.of_applyS` occurs. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.focusedActionPreimage
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r)
+    {Gamma : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {A : SExpr} {rho : Valuation} {out : TShape}
+    (action : Pattern.Action Gamma r e ls capture A)
+    (hLeft : StrongSound Gamma e A)
+    (W : Valuation.Fits Gamma0 Gamma rho)
+    (hRhs : LE_Interp.Witness rho out (r.1.applyS ls capture))
+    (hRhsStratified : HasTypeStratifiedS Gamma
+      (r.1.applyS ls capture) A true rhsDepth)
+    (hout : ¬out ≤ TShape.bot) :
+    Nonempty (rule.FocusedActionPreimage action hRhs rhsDepth) := by
+  obtain ⟨mcap, hcap, head, hhead, hspine⟩ :=
+    rule.focusedShapeSpine hRhs hout
+  obtain ⟨headType, hheadStratified⟩ :=
+    rule.rhsHeadStratified hRhsStratified
+  obtain ⟨threshold, built⟩ :=
+    LE_Interp.build_spine action.matched W hLeft
+      (Params.pat_wf action.pat) hcap
+  obtain ⟨constantName, args, matchedCapture, argExprs,
+    hmatch, hcapture, hargs, hlhs⟩ :=
+    built threshold (Nat.le_refl threshold)
+  refine ⟨{
+    rhsStratified := hRhsStratified
+    headType := headType
+    headStratified := hheadStratified
+    mcap := mcap
+    captureInterp := hcap
+    head := head
+    headWitness := hhead
+    spine := hspine
+    argLevel := threshold
+    constantName := constantName
+    args := args
+    matchedCapture := matchedCapture
+    argExprs := argExprs
+    matched := hmatch
+    capture_le := hcapture
+    argsInterp := hargs
+    lhs_eq := hlhs
+    constantInterp := ?_ }⟩
+  exact .pat action.pat hmatch
+    ((rule.focusedRHS hhead hspine).mono_l hcapture)
+
+/-- Realize the redex stored by a focused reverse-action certificate at the
+caller's exact typed observation.
+
+The returned witness is built with `appsRealizeFocused`; unfolding this
+definition exposes the certificate's `headWitness.LowerEdge` relation at the
+constant node.  A later `RDeepChildren` rebuild can therefore attach its
+local seed to the same fixed-head witness that was peeled from the RHS. -/
+noncomputable def _root_.Lean4Lean.Pattern.IotaRule.FocusedActionPreimage.witness
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r}
+    {Gamma : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {A : SExpr} {rho : Valuation} {out outTy : TShape}
+    {action : Pattern.Action Gamma r e ls capture A}
+    {hRhs : LE_Interp.Witness rho out (r.1.applyS ls capture)}
+    {rhsDepth : Nat}
+    (H : rule.FocusedActionPreimage action hRhs rhsDepth)
+    (W : Valuation.Fits Gamma0 Gamma rho)
+    (hLeft : StrongSound Gamma e A)
+    (hout : out.HasType outTy)
+    (hA : LE_Interp.Witness rho outTy A) :
+    LE_Interp.Witness rho out e := by
+  let hbuilt := LE_Interp.Witness.appsRealizeFocused
+    W hout hA (H.lhs_eq.symm ▸ hLeft) H.argsInterp
+    H.headWitness H.constantInterp
+  exact H.lhs_eq ▸ hbuilt
+
+/-- Semantic strong typing of a constant needs its constructor bundles but
+not its definition unfoldings.  Keeping this fragment separate is what lets
+the definition-only strong constructor type its left endpoint finitely. -/
+theorem StrongSound.of_const
+    (hreg : Params.env.constants c = some ci)
+    (hlen : ls.length = ci.uvars)
+    (F : ∀ cl, CtorBundle c cl)
+    (hF : ∀ cl, StrongSoundEq Γ (SExpr.mkInst ls ci.type)
+      ((F cl).rhs ls) (.sort (F cl).u)) :
+    StrongSound Γ (.const c ls) (SExpr.mkInst ls ci.type) := by
+  refine ⟨.const hreg hlen, fun _ _ W _ h => ?_,
+    .const hreg hlen F (fun cl => (hF cl).sound) (fun cl => (hF cl).right),
+    .rfl⟩
+  generalize eq : SExpr.const c ls = M at h
+  induction h with cases eq
+  | bot => exact .mk .rfl .bot .bot (.bot_T' <| .bot .sort)
+  | const b1 b2 b3 b4 b5 b6 b7 =>
+    cases hreg.symm.trans b1
+    exact .mk b3 (.const b1 b2 .rfl b4 b5 b6 b7) b5 b4
+
+/-- Turn one proof-carrying local contraction into semantic soundness once
+both endpoints have independently obtained strong typings. -/
+theorem StrongSoundEq.ofAction
+    (action : Pattern.Action Γ r e m1 m2 A)
+    (hLeft : StrongSound Γ e A)
+    (hRight : StrongSound Γ (r.1.applyS m1 m2) A) :
+    StrongSoundEq Γ e (r.1.applyS m1 m2) A := by
+  refine ⟨action.sound, fun Γ₀ ρ W m => ?_, hLeft, hRight⟩
+  by_cases hm : m ≤ TShape.bot
+  · exact TShape.le_bot'.1 hm ▸ (LE_Interp.sound_bot (A := default)).1
+  refine ⟨fun hLE => ?_, fun hLE => ?_⟩
+  · obtain ⟨_, built⟩ :=
+      LE_Interp.Matches.of_matchesS action.matched
+        (Params.pat_wf action.pat) hLE
+    obtain ⟨_, rargs, m_path, m_head, hMatch, hpath, hle, hConst⟩ :=
+      built _ (Nat.le_refl _)
+    cases hConst with
+    | bot => cases hm (hle.trans TShape.bot_eqv.1)
+    | lam hRec hle_lam =>
+      refine hm ((hle.trans hle_lam).trans ?_) |>.elim
+      rw [WShape.lam']
+      split <;> [rename_i hf; exact TShape.bot_eqv.1]
+      obtain ⟨⟨s, t⟩, hxy, hn⟩ := WShapeFun.NonZero.iff.1 hf
+      refine (hn (WShape.LE.T_iff.1 (.trans ?_ TShape.bot_eqv.2))).elim
+      exact (hRec s t hxy).compat_mismatch (by simp) <|
+        .inr <| .inr ⟨_, _, _, action.pat, hMatch⟩
+    | ctor h | indTy h =>
+      obtain ⟨_, h_symb⟩ := hMatch.head_wf (Params.pat_wf action.pat)
+      cases h ▸ h_symb
+    | pat hP hM hRHS' =>
+      obtain ⟨_, hi⟩ := hM.matches_inter (.rfl fun _ _ => .rfl)
+        (Params.pat_wf hP) hMatch (Params.pat_wf action.pat)
+      obtain ⟨rfl, -, ⟨⟩⟩ := Params.pat_uniq action.pat hP .refl hi
+      exact .mono hle <| LE_Interp.RHS.le_applyS hpath (fun _ _ => id) <|
+        LE_Interp.Matches.unique (Params.pat_wf action.pat) hM hMatch ▸ hRHS'
+  · have ⟨_, _, a, hm_lvl, hm_le_typed, h_LE_m_typed_R, ha,
+        h_m_typed_HT⟩ := (hRight.sound W hLE).out
+    obtain ⟨m_path_T, hpath, hRHS⟩ :=
+      LE_Interp.RHS.of_applyS h_LE_m_typed_R
+    obtain ⟨_, built⟩ :=
+      LE_Interp.build_spine action.matched W hLeft
+        (Params.pat_wf action.pat) hpath
+    obtain ⟨c, rargs, m', rAs, hMatch, hbnd, h_per_arg, h_foldr_eq⟩ :=
+      built _ (Nat.le_refl _)
+    exact .mono hm_le_typed <| h_foldr_eq ▸
+      LE_Interp.apps_realize W h_m_typed_HT.T ha
+      (h_foldr_eq ▸ hLeft) h_per_arg (.pat action.pat hMatch (hRHS.mono_l hbnd))
+
+theorem LE_Interp.strongSound (H : IsDefEqStrong Γ M N A) : StrongSoundEq Γ M N A := by
   induction H with
   | @bvar _ i A _ h h2 ih =>
     refine .rfl ⟨.bvar h, fun _ _ W _ h => ?_, .bvar h, .rfl⟩; clear h2 ih
@@ -5054,26 +9598,16 @@ theorem LE_Interp.strongSound (H : Γ ⊢ M ≡ N : A) : StrongSoundEq Γ M N A
     | zero => exact ⟨_, _, a1, .bvar .rfl, h2.weak, h3⟩
     | succ h => have ⟨_, _, le, h1, h2, h3⟩ := ih h a1; exact ⟨_, _, le, h1.weak, h2.weak, h3⟩
   | symm _ ih => exact ih.symm
-  | trans H _ _ _ ih1 ih2 => exact ih1.trans ih2
-  | trans' _ _ ih1 ih2 =>
-    have ⟨a1, a2, a3, a4, a5, a6, a7⟩ := ih1; have ⟨b1, b2, _, b4, b5, b6, b7⟩ := ih2
-    have := ih2.left.uniq ih1.right
-    refine ⟨.trans' a1 b1, a2.trans b2, a3, ?_, b5.defeq_r this, b6, b7.trans this⟩
-    exact ((a1.symm.trans' a1).trans' b1).symm.trans' b1
+  | trans _ _ ih1 ih2 => exact ih1.trans ih2
   | @sort _ l =>
     refine .rfl ⟨.sort, fun _ _ W _ h => ?_, .sort, .rfl⟩
     generalize eq : SExpr.sort l = M at h
     induction h with cases eq
     | bot => exact .mk .rfl .bot .bot (.bot_T' <| .bot .sort)
     | sort h1 => exact .mk h1 (.sort .rfl) (.sort .rfl) (by simpa using .sort)
-  | @const c _ _ ls _ a1 a2 a3 F a4 ih1 ih2 =>
-    refine .rfl ⟨.const a1 a2, fun _ _ W _ h => ?_,
-      .const a1 a2 F (fun h => (ih2 h).sound) (fun h => (ih2 h).right), .rfl⟩
-    generalize eq : SExpr.const c ls = M at h
-    induction h with cases eq | const b1 b2 b3 b4 b5 b6 b7 => ?_ | bot =>
-      exact .mk .rfl .bot .bot (.bot_T' <| .bot .sort)
-    cases a1.symm.trans b1; exact .mk b3 (.const b1 b2 .rfl b4 b5 b6 b7) b5 b4
-  | appDF _ _ _ _ ihA ih1 ih2 ih3 =>
+  | @const c _ _ ls _ a1 a2 a3 F a4 hDef ih1 ih2 ihDef =>
+    exact .rfl (StrongSound.of_const a1 a2 F ih2)
+  | appDF _ _ _ _ _ ihA _ ih1 ih2 ih3 =>
     refine .mk' (.appDF ih1.defeq ih2.defeq)
       (.app ihA.left.sound ih1.left ih2.left) .rfl
       (.app ihA.left.sound ih1.right ih2.right) ih3.sound.symm fun _ _ W m => ?_
@@ -5083,7 +9617,7 @@ theorem LE_Interp.strongSound (H : Γ ⊢ M ≡ N : A) : StrongSoundEq Γ M N A
       cases h with | bot => cases hm TShape.bot_le' | app h1 h2 h3
     · exact .app ((ih1.sound W).1 h1) ((ih2.sound W).1 h2) h3
     · exact .app ((ih1.sound W).2 h1) ((ih2.sound W).2 h2) h3
-  | lamDF _ _ _ _ ih1 _ ih2 ih3 =>
+  | lamDF _ _ _ _ _ ih1 _ _ ih2 ih3 =>
     refine .mk' (.lamDF ih1.defeq ih2.defeq)
       (.lam ih1.left.sound ih2.left) .rfl
       (.lam ih1.right.sound ih3.right)
@@ -5216,42 +9750,292 @@ theorem LE_Interp.strongSound (H : Γ ⊢ M ≡ N : A) : StrongSoundEq Γ M N A
     have ⟨_, _, b1, b2, b3, b4⟩ := ih1.left.sound W a3
     have b4' := TShape.HasType.mono_r (by simpa using b3.le_sort) .sort b4
     exact a1.trans (b4'.proofIrrel (b4'.mono_r b1 a4))
-  | extra h1 h2 hTy_lhs hTy_rhs ih1 ih2 =>
-    refine ⟨.extra h1 h2, fun Γ₀ ρ W m => ?_, ih1.left, ih2.left⟩
-    by_cases hm : m ≤ .bot; · exact TShape.le_bot'.1 hm ▸ (sound_bot (A := default)).1
-    let ⟨p, r, m1, m2, dfs, a1, a2, a3, a4, a5⟩ := Params.extra_pat Γ₀ h1 h2
-    refine a5 ▸ ⟨fun hLE => ?_, fun hLE => ?_⟩
-    · obtain ⟨_, built⟩ := Matches.of_matchesS a2 (Params.pat_wf a1) hLE
-      obtain ⟨_, rargs, m_path, m_head, hMatch, hpath, hle, hConst⟩ := built _ (Nat.le_refl _)
-      cases hConst with
-      | bot => cases hm (hle.trans TShape.bot_eqv.1)
-      | lam hRec hle_lam =>
-        refine hm ((hle.trans hle_lam).trans ?_) |>.elim
-        rw [WShape.lam']; split <;> [rename_i hf; exact TShape.bot_eqv.1]
-        obtain ⟨⟨s, t⟩, hxy, hn⟩ := WShapeFun.NonZero.iff.1 hf
-        refine (hn (WShape.LE.T_iff.1 (.trans ?_ TShape.bot_eqv.2))).elim
-        exact (hRec s t hxy).compat_mismatch (by simp) <| .inr <| .inr ⟨_, _, _, a1, hMatch⟩
-      | ctor h | indTy h =>
-        obtain ⟨_, h_symb⟩ := hMatch.head_wf (Params.pat_wf a1)
-        cases h ▸ h_symb
-      | pat hP hM hRHS'
-      obtain ⟨_, hi⟩ := hM.matches_inter (.rfl fun _ _ => .rfl)
-        (Params.pat_wf hP) hMatch (Params.pat_wf a1)
-      obtain ⟨rfl, -, ⟨⟩⟩ := Params.pat_uniq a1 hP .refl hi
-      exact .mono hle <| RHS.le_applyS hpath (fun _ _ => id) <|
-        Matches.unique (Params.pat_wf a1) hM hMatch ▸ hRHS'
-    · have ⟨_, _, a, hm_lvl, hm_le_typed, h_LE_m_typed_R, ha, h_m_typed_HT⟩ :=
-        (ih2.left.sound W (a5.symm ▸ hLE)).out
-      obtain ⟨m_path_T, hpath, hRHS⟩ := RHS.of_applyS (a5 ▸ h_LE_m_typed_R)
-      obtain ⟨_, built⟩ := build_spine a2 W ih1.left (Params.pat_wf a1) hpath
-      obtain ⟨c, rargs, m', rAs, hMatch, hbnd, h_per_arg, h_foldr_eq⟩ := built _ (Nat.le_refl _)
-      exact .mono hm_le_typed <| h_foldr_eq ▸ apps_realize W h_m_typed_HT.T ha
-        (h_foldr_eq ▸ ih1.left) h_per_arg (.pat a1 hMatch (hRHS.mono_l hbnd))
-
-theorem LE_Interp.sound (H : Γ ⊢ M ≡ N : A) (W : Valuation.Fits Γ₀ Γ ρ) {m} :
+  | @defn c ci Γ ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    exact StrongSoundEq.ofAction action
+      (StrongSound.of_const hreg hlen F ihF) ihRhs.left
+  | extra action hTy_lhs hTy_rhs ih1 ih2 =>
+    exact StrongSoundEq.ofAction action ih1.left ih2.left
+
+theorem LE_Interp.sound (H : IsDefEqStrong Γ M N A) (W : Valuation.Fits Γ₀ Γ ρ) {m} :
     (LE_Interp ρ m M ↔ LE_Interp ρ m N) ∧ (LE_Interp ρ m M → InterpTyped ρ m M A) :=
   ⟨(strongSound H).sound W, (strongSound H).left.sound W⟩
 
+/-- A source valuation whose non-identity entries retain exact witnesses
+for their syntactic types and every recursive constant edge below them. -/
+inductive LE_Interp.Witness.FitsRDeep
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (base : List SExpr) : List SExpr → Valuation → Prop where
+  | nil : FitsRDeep P base base .nil
+  | cons : FitsRDeep P base Γ ρ →
+    (∃ a, ∃ hA : LE_Interp.Witness ρ a A,
+      x.HasType a ∧ hA.RDeepChildren P) →
+    FitsRDeep P base (A :: Γ) (ρ.push x)
+
+theorem LE_Interp.Witness.FitsRDeep.lookup
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (W : LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ)
+    (H : Lookup Γ i A) :
+    LE_Interp.Witness.TypedRDeep P ρ (ρ i) (.bvar i) A := by
+  induction W generalizing i A with
+  | nil => exact .bot TShape.bot_eqv.1
+  | @cons Γ' ρ' A' x W binding ih =>
+    cases H with
+    | zero =>
+      obtain ⟨a, hA, hxa, cA⟩ := binding
+      let hvar : LE_Interp.Witness (ρ'.push x) x (.bvar 0) := .bvar .rfl
+      exact ⟨x, a, hvar, hA.weak, .rfl, hxa,
+        .bvar, cA.weak laws.closed⟩
+    | succ H =>
+      simpa [Valuation.push, SExpr.lift, SExpr.lift', Lift.liftVar,
+        Nat.add_comm] using (ih H).weak laws.closed (x := x)
+
+theorem LE_Interp.Witness.FitsRDeep.push
+    (W : LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ)
+    (hA : LE_Interp.Witness.TypeRDeep P ρ a A)
+    (hx : x.HasType a) :
+    LE_Interp.Witness.FitsRDeep P Γ₀ (A :: Γ) (ρ.push x) := by
+  obtain ⟨a', hA, hle, ha', cA⟩ := hA
+  exact .cons W ⟨a', hA, ha'.mono_r hle hx, cA⟩
+
+/-- Choose exact binding witnesses from an ordinary valid valuation.  The
+retained predicate is trivial, so this changes no public semantic content. -/
+theorem Valuation.Fits.toFitsRDeepTrue
+    (W : Valuation.Fits Γ₀ Γ ρ) :
+    LE_Interp.Witness.FitsRDeep (fun _ => True) Γ₀ Γ ρ := by
+  induction W with
+  | nil => exact .nil
+  | cons _ _ hA hx ih =>
+    exact .cons ih ⟨_, hA.witness, hx,
+      LE_Interp.Witness.RDeepChildren.trivial _⟩
+
+/-- Retained semantic typing for every stratified derivation at one exact
+depth. Public valuation validity is kept alongside the exact witness trees
+because semantic conversion is intentionally proof-independent. -/
+def LE_Interp.Witness.SoundRDeepAt
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (Γ₀ : List SExpr) {ρ m M}
+    (hM : LE_Interp.Witness ρ m M) (d : Nat) : Prop :=
+  ∀ {Γ A core}, HasTypeStratifiedS Γ M A core d →
+    LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ →
+    Valuation.Fits Γ₀ Γ ρ →
+    LE_Interp.Witness.TypedRDeep P ρ m M A
+
+/-- Prove retained semantic typing below a fixed depth bound. Syntax-directed
+children use the ordinary typing induction; conversion and binder valuation
+validity restart on an arbitrary exact witness only after a strict depth
+decrease. -/
+theorem LE_Interp.Witness.soundRDeepRestart
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (restart : ∀ (d' : Nat), d' < D → ∀ {ρ m M}
+      (hM' : LE_Interp.Witness ρ m M),
+      P hM' ∧ hM'.RDeepChildren P ∧
+        LE_Interp.Witness.SoundRDeepAt P Γ₀ hM' d')
+    (H : HasTypeStratifiedS Γ M A core d)
+    (hd : d ≤ D)
+    (W : LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ)
+    (hM : LE_Interp.Witness ρ m M)
+    (childrenP : hM.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m M A := by
+  induction H generalizing ρ m with
+  | base _ ih => exact ih hd W Wfits hM childrenP
+  | @sort' Γ l d =>
+    let tm := TShape.sort (decide (l ≠ .zero))
+    let ty := TShape.type
+    let hterm : LE_Interp.Witness ρ tm (.sort l) := .sort .rfl
+    let htype : LE_Interp.Witness ρ ty (.sort l.succ) :=
+      .sort (by simpa [ty, TShape.type] using
+        (TShape.LE.rfl : TShape.sort true ≤ TShape.sort true))
+    exact ⟨tm, ty, hterm, htype, hM.toInterp.le_sort, .sort, .sort, .sort⟩
+  | @bvar Γ i A u d hlookup hA ihA =>
+    have hle := LE_Interp.bvar_iff.1 hM.toInterp
+    exact (W.lookup laws hlookup).mono hle
+  | @const c ci Γ ls u d hreg hlen hTy ihTy =>
+    cases hM with
+    | bot => exact .bot TShape.bot_eqv.1
+    | @const _ _ ci' _ m' _ a' _ R hreg' hlen' hle hty hA hC hR =>
+      cases hreg.symm.trans hreg'
+      cases childrenP with
+      | const cA pR cR =>
+        let hconst : LE_Interp.Witness ρ m' (.const c ls) :=
+          .const hreg hlen .rfl hty hA hC hR
+        exact ⟨m', a', hconst, hA, hle, hty,
+          .const cA pR cR, cA⟩
+  | @app Γ A u n B v f a hA hCod hf ha hResult
+      ihA ihCod ihf iha ihResult =>
+    have hnD : n ≤ D := Nat.le_trans (Nat.le_succ n) hd
+    exact LE_Interp.Witness.TypedRDeep.app
+      (F := f) (A := A) (B := B) (X := a)
+      laws.mono_l laws.closed
+      (H1 := fun hF cF => ihf hnD W Wfits hF cF)
+      (H2 := fun hB cB => (ihResult hnD W Wfits hB cB).toType)
+      childrenP
+  | @lam Γ A u n B v body hA hB hbody hPi
+      ihA ihB ihbody ihPi =>
+    have hnD : n ≤ D := Nat.le_trans (Nat.le_succ n) hd
+    have hnLtD : n < D := Nat.lt_of_lt_of_le (Nat.lt_succ_self n) hd
+    have fitType : ∀ {a}, LE_Interp ρ a A →
+        ∃ a', a ≤ a' ∧ LE_Interp ρ a' A ∧ a'.HasType .type := by
+      intro a ha
+      let wa := ha.witness
+      have qa := restart n hnLtD wa
+      obtain ⟨a', hA', hle, hty, _⟩ :=
+        (qa.2.2 hA W Wfits).toType
+      exact ⟨a', hle, hA'.toInterp, hty⟩
+    exact LE_Interp.Witness.TypedRDeep.lam laws
+      (H2 := fun {a x} hDom cDom hx {e} hBody cBody =>
+        ihbody hnD
+          (W.push (ihA hnD W Wfits hDom cDom).toType hx)
+          (Wfits.cons fitType hDom.toInterp hx) hBody cBody)
+      childrenP
+  | @forallE Γ A u n body v hA hbody ihA ihbody =>
+    have hnD : n ≤ D := Nat.le_trans (Nat.le_succ n) hd
+    have hnLtD : n < D := Nat.lt_of_lt_of_le (Nat.lt_succ_self n) hd
+    have fitType : ∀ {a}, LE_Interp ρ a A →
+        ∃ a', a ≤ a' ∧ LE_Interp ρ a' A ∧ a'.HasType .type := by
+      intro a ha
+      let wa := ha.witness
+      have qa := restart n hnLtD wa
+      obtain ⟨a', hA', hle, hty, _⟩ :=
+        (qa.2.2 hA W Wfits).toType
+      exact ⟨a', hle, hA'.toInterp, hty⟩
+    exact LE_Interp.Witness.TypedRDeep.forallE laws
+      (H1 := fun hDom cDom => ihA hnD W Wfits hDom cDom)
+      (H2 := fun {a x} hDom cDom hx {e} hBody cBody =>
+        ihbody hnD
+          (W.push (ihA hnD W Wfits hDom cDom).toType hx)
+          (Wfits.cons fitType hDom.toInterp hx) hBody cBody)
+      childrenP
+  | @defeq Γ A B u n e hEq hA hB he ihA ihB ihe =>
+    have hnD : n ≤ D := Nat.le_trans (Nat.le_succ n) hd
+    have hnLtD : n < D := Nat.lt_of_lt_of_le (Nat.lt_succ_self n) hd
+    obtain ⟨tm, a, he', hA', hle, htyped, ce, cA⟩ :=
+      ihe hnD W Wfits hM childrenP
+    have hBpublic : LE_Interp ρ a B :=
+      (LE_Interp.sound hEq Wfits).1.1 hA'.toInterp
+    let hB0 := hBpublic.witness
+    have qB := restart n hnLtD hB0
+    obtain ⟨b, hB', hab, hbtype, cB⟩ :=
+      (qB.2.2 hB W Wfits).toType
+    exact ⟨tm, b, he', hB', hle,
+      hbtype.mono_r hab htyped, ce, cB⟩
+
+/-- Combine a consumer property with its retained tree and stratified semantic
+typing. The caller proves the property at one witness from same-depth `R`-edge
+results and strictly-smaller-depth restarts; the Nat-first witness recursor
+supplies the well-founded fixed point. -/
+theorem LE_Interp.Witness.recNatRDeepSound
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (buildP : ∀ (d : Nat) {ρ m M}
+        (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' =>
+        P hM' ∧ hM'.RDeepChildren P ∧
+          LE_Interp.Witness.SoundRDeepAt P Γ₀ hM' d) →
+      (∀ (d' : Nat), d' < d → ∀ {ρ m M}
+        (hM' : LE_Interp.Witness ρ m M),
+        P hM' ∧ hM'.RDeepChildren P ∧
+          LE_Interp.Witness.SoundRDeepAt P Γ₀ hM' d') →
+      P hM)
+    {ρ m M} (hM : LE_Interp.Witness ρ m M) : ∀ d,
+      P hM ∧ hM.RDeepChildren P ∧
+        LE_Interp.Witness.SoundRDeepAt P Γ₀ hM d := by
+  let Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop :=
+    fun hM d => P hM ∧ hM.RDeepChildren P ∧
+      LE_Interp.Witness.SoundRDeepAt P Γ₀ hM d
+  change ∀ d, Q hM d
+  apply hM.recNatRDeep (Q := Q)
+  intro d ρ m M hM children lower
+  dsimp only [Q] at children lower ⊢
+  have childrenP : hM.RDeepChildren P :=
+    children.map (fun _ h => h.1)
+  refine ⟨buildP d hM children lower, childrenP, ?_⟩
+  intro Γ A core H W Wfits
+  exact LE_Interp.Witness.soundRDeepRestart laws lower H (Nat.le_refl d)
+    W Wfits hM childrenP
+
+
+/-- Separate the exact-edge consumer from the predicate retained by semantic
+typing. -/
+theorem LE_Interp.Witness.recNatRDeepConsumer
+    {C T : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (laws : LE_Interp.Witness.RDeepChildren.Laws T)
+    (toTree : ∀ {ρ m M} (hM : LE_Interp.Witness ρ m M), C hM → T hM)
+    (buildC : ∀ (d : Nat) {ρ m M}
+        (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' =>
+        C hM' ∧ hM'.RDeepChildren T ∧
+          LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d) →
+      (∀ (d' : Nat), d' < d → ∀ {ρ m M}
+        (hM' : LE_Interp.Witness ρ m M),
+        C hM' ∧ hM'.RDeepChildren T ∧
+          LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d') →
+      C hM)
+    {ρ m M} (hM : LE_Interp.Witness ρ m M) : ∀ d,
+      C hM ∧ hM.RDeepChildren T ∧
+        LE_Interp.Witness.SoundRDeepAt T Γ₀ hM d := by
+  let Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop :=
+    fun hM d => C hM ∧ hM.RDeepChildren T ∧
+      LE_Interp.Witness.SoundRDeepAt T Γ₀ hM d
+  change ∀ d, Q hM d
+  apply hM.recNatRDeep (Q := Q)
+  intro d ρ m M hM children lower
+  dsimp only [Q] at children lower ⊢
+  have childrenT : hM.RDeepChildren T :=
+    children.map (fun h q => toTree h q.1)
+  have restartT : ∀ (d' : Nat), d' < d → ∀ {ρ m M}
+      (hM' : LE_Interp.Witness ρ m M),
+      T hM' ∧ hM'.RDeepChildren T ∧
+        LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d' := by
+    intro d' hd' ρ m M hM'
+    have q := lower d' hd' hM'
+    exact ⟨toTree hM' q.1, q.2⟩
+  refine ⟨buildC d hM children lower, childrenT, ?_⟩
+  intro Γ A core H W Wfits
+  exact hM.soundRDeepRestart laws restartT H (Nat.le_refl d)
+    W Wfits childrenT
+
+/-- Depth-indexed form of `recNatRDeepConsumer`. -/
+theorem LE_Interp.Witness.recNatRDeepConsumerAt
+    {C : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop}
+    {T : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    (laws : LE_Interp.Witness.RDeepChildren.Laws T)
+    (toTree : ∀ (d : Nat) {ρ m M}
+      (hM : LE_Interp.Witness ρ m M), C hM d → T hM)
+    (buildC : ∀ (d : Nat) {ρ m M}
+        (hM : LE_Interp.Witness ρ m M),
+      hM.RDeepChildren (fun hM' =>
+        C hM' d ∧ hM'.RDeepChildren T ∧
+          LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d) →
+      (∀ (d' : Nat), d' < d → ∀ {ρ m M}
+        (hM' : LE_Interp.Witness ρ m M),
+        C hM' d' ∧ hM'.RDeepChildren T ∧
+          LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d') →
+      C hM d)
+    {ρ m M} (hM : LE_Interp.Witness ρ m M) : ∀ d,
+      C hM d ∧ hM.RDeepChildren T ∧
+        LE_Interp.Witness.SoundRDeepAt T Γ₀ hM d := by
+  let Q : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Nat → Prop :=
+    fun hM d => C hM d ∧ hM.RDeepChildren T ∧
+      LE_Interp.Witness.SoundRDeepAt T Γ₀ hM d
+  change ∀ d, Q hM d
+  apply hM.recNatRDeep (Q := Q)
+  intro d ρ m M hM children lower
+  dsimp only [Q] at children lower ⊢
+  have childrenT : hM.RDeepChildren T :=
+    children.map (fun h q => toTree d h q.1)
+  have restartT : ∀ (d' : Nat), d' < d → ∀ {ρ m M}
+      (hM' : LE_Interp.Witness ρ m M),
+      T hM' ∧ hM'.RDeepChildren T ∧
+        LE_Interp.Witness.SoundRDeepAt T Γ₀ hM' d' := by
+    intro d' hd' ρ m M hM'
+    have q := lower d' hd' hM'
+    exact ⟨toTree d' hM' q.1, q.2⟩
+  refine ⟨buildC d hM children lower, childrenT, ?_⟩
+  intro Γ A core H W Wfits
+  exact hM.soundRDeepRestart laws restartT H (Nat.le_refl d)
+    W Wfits childrenT
+
 structure LogRelBase (Γ : List SExpr) (n : Nat) where
   /-- Term validity: `M ≡ N : A` at element-shape `m` and type-shape `a`. -/
   DefEq (M N A : SExpr) (m a : WShape n) : Prop
@@ -5280,6 +10064,103 @@ structure LogRel (Γ : List SExpr) (n : Nat) extends LogRelBase Γ n where
   whr : Γ ⊢ M ⤳* M' → Γ ⊢ N ⤳* N' → (DefEq M N A m a ↔ DefEq M' N' A m a)
   whr_ty : Γ ⊢ A ⤳* A' → Γ ⊢ B ⤳* B' → (TyDefEq A B m ↔ TyDefEq A' B' m)
 
+/-- The three synchronized edges produced by evaluating two related heads
+at two related arguments.  The horizontal edges are the endpoint
+self-congruences; the diagonal is the heterogeneous result ultimately
+consumed by `LamDefEq`.  Packaging them together is important at semantic
+transport boundaries: retyping the diagonal may require the two endpoint
+witnesses at the very same observation. -/
+structure LogRel.DefEqRect (R : LogRel Γ n)
+    (M₁ M₂ N₁ N₂ A : SExpr) (m a : WShape n) : Prop where
+  left : R.DefEq M₁ M₂ A m a
+  right : R.DefEq N₁ N₂ A m a
+  cross : R.DefEq M₁ N₂ A m a
+
+/-- A single logical-relation edge supplies the degenerate rectangle used
+when both evaluated heads coincide. -/
+theorem LogRel.DefEqRect.diagonal
+    (H : R.DefEq M₁ M₂ A m a) :
+    LogRel.DefEqRect R M₁ M₂ M₁ M₂ A m a :=
+  ⟨H, H, H⟩
+
+/-- Compose two synchronized rectangles that share their middle endpoints. -/
+theorem LogRel.DefEqRect.trans
+    (H₁ : LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a)
+    (H₂ : LogRel.DefEqRect R M₂ M₃ N₂ N₃ A m a) :
+    LogRel.DefEqRect R M₁ M₃ N₁ N₃ A m a :=
+  ⟨R.trans H₁.left H₂.left,
+    R.trans H₁.right H₂.right,
+    R.trans H₁.cross H₂.right⟩
+
+/-- Convert the common declared type of all three rectangle edges. -/
+theorem LogRel.DefEqRect.conv
+    (hAB : R.TyDefEq A B a)
+    (H : LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a) :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ B m a :=
+  ⟨R.conv hAB H.left, R.conv hAB H.right, R.conv hAB H.cross⟩
+
+/-- Lower the common element observation of a rectangle. -/
+theorem LogRel.DefEqRect.mono_l
+    (hle : m ≤ m') (hm : m.HasType a) (hm' : m'.HasType a)
+    (H : LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m' a) :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a :=
+  ⟨R.mono_l hle hm hm' H.left,
+    R.mono_l hle hm hm' H.right,
+    R.mono_l hle hm hm' H.cross⟩
+
+/-- Raise the common type observation of a rectangle. -/
+theorem LogRel.DefEqRect.mono_r_1
+    (hle : a ≤ a') (hma : m.HasType a) (hma' : m.HasType a')
+    (hA : R.TyDefEq A A a')
+    (H : LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a) :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a' :=
+  ⟨R.mono_r_1 hle hma hma' hA H.left,
+    R.mono_r_1 hle hma hma' hA H.right,
+    R.mono_r_1 hle hma hma' hA H.cross⟩
+
+/-- Lower the common type observation of a rectangle. -/
+theorem LogRel.DefEqRect.mono_r_2
+    (hle : a ≤ a') (hma : m.HasType a) (ha' : a'.HasType .type)
+    (H : LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a') :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a :=
+  ⟨R.mono_r_2 hle hma ha' H.left,
+    R.mono_r_2 hle hma ha' H.right,
+    R.mono_r_2 hle hma ha' H.cross⟩
+
+/-- Weak-head normalize all four endpoints of a rectangle in lockstep. -/
+theorem LogRel.DefEqRect.whr
+    {R : LogRel Γ n}
+    (hM₁ : WHRedS Γ M₁ M₁') (hM₂ : WHRedS Γ M₂ M₂')
+    (hN₁ : WHRedS Γ N₁ N₁') (hN₂ : WHRedS Γ N₂ N₂') :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a ↔
+      LogRel.DefEqRect R M₁' M₂' N₁' N₂' A m a := by
+  constructor
+  · intro H
+    exact ⟨(R.whr hM₁ hM₂).1 H.left,
+      (R.whr hN₁ hN₂).1 H.right,
+      (R.whr hM₁ hN₂).1 H.cross⟩
+  · intro H
+    exact ⟨(R.whr hM₁ hM₂).2 H.left,
+      (R.whr hN₁ hN₂).2 H.right,
+      (R.whr hM₁ hN₂).2 H.cross⟩
+
+/-- Transport a term relation from one valid type shape to another through a
+semantic equality at their join.  This packages the raise/convert/lower
+pattern used by successor-level lambda retyping. -/
+theorem LogRel.DefEq.retype_join {R : LogRel Γ n}
+    (compat : a.Compat b)
+    (hpA : p.HasType a) (hpB : p.HasType b)
+    (hTy : R.TyDefEq A B (a.join b))
+    (hxy : R.DefEq x y B p b) :
+    R.DefEq x y A p a := by
+  have hjoin := WShape.Join.mk compat
+  have htypeJoin := WShape.HasType.join compat hpA.isType hpB.isType
+  have hpJoin := WShape.HasType.mono_r hjoin.le.1 htypeJoin hpA
+  have hBB := R.left_ty (R.symm_ty hTy)
+  have hxyJoin := R.mono_r_1 hjoin.le.2 hpB hpJoin hBB hxy
+  have hxyA := R.conv (R.symm_ty hTy) hxyJoin
+  exact R.mono_r_2 hjoin.le.1 hpA htypeJoin hxyA
+
 theorem LogRelBase.TyDefEq.sort {R : LogRel Γ n} : R.TyDefEq (.sort u) (.sort u) (.sort r) :=
   R.toType (A := default) (r := default) (R.sort_iff.2 ⟨_, .rfl, .rfl⟩)
 
@@ -5360,25 +10241,49 @@ def LR0 : LogRel Γ 0 where
 
 /-! #### Concrete definitions at level n+1 -/
 
+/-! `TypeDefEqPath` and its conversion API (`single`, `trans`, `leftType`,
+`rightType`, `left`, `right`, `symm`, `defeqDF`, `defeqDF_l`,
+`defeqDF_l_path`, `subst`) moved to `Lean4Lean/Experimental/SExpr.lean` on
+2026-08-15, beside `IsDefEq.defeqDF_l` and `IsDefEq.subst`, which are its only
+inputs.  Nothing about it was logical-relation-flavoured, and the relocation
+is what lets `IsDefEqStrong.app_inv'` / `.lam_inv'` / `.forallE_inv_path`
+state their conclusions there.  `TypeDefEqPath.collapse` (below) stays here:
+its extra input `LogRel.RawTypeUniq` is declared here. -/
+
+/-- The four synchronized facts retained after applying a Pi codomain to
+related arguments.  The raw equalities are the evidence needed by dependent
+application/spine construction; the semantic equalities are what the
+logical relation consumes. -/
+structure LRS.PiInstDefEq (IH : LogRel Γ n) (F₁ F₂ a b : SExpr)
+    (p : WShape n) : Prop where
+  leftTy : IH.TyDefEq (F₁.inst a) (F₁.inst b) p
+  rightTy : IH.TyDefEq (F₂.inst a) (F₂.inst b) p
+  leftDefEq : ∃ u, Γ ⊢ F₁.inst a ≡ F₁.inst b : .sort u
+  rightDefEq : ∃ u, Γ ⊢ F₂.inst a ≡ F₂.inst b : .sort u
+
 /-- Pi edge validity (merged `PiEdgeDefEq` / `PiEdgeEq2`).
-For each argument `a ≡ b : A₁`, the substituted codomains are valid types.
-For each argument `a : A₁`, the codomains `A₂[a]` and `B₂[a]` are equal types. -/
+For each argument `a ≡ b : A₁`, the substituted codomains are valid and
+raw-equal types.  For each argument `a : A₁`, the codomains `A₂[a]` and
+`B₂[a]` are equal types. -/
 def LRS.PiDefEq (IH : LogRel Γ n)
     (B F₁ F₂ : SExpr) (b : WShape n) (f : WShapeFun n) : Prop :=
   (∀ {{a b' p}}, p.HasType b → Γ ⊢ a ≡ b' : B → IH.DefEq a b' B p b →
-    IH.TyDefEq (F₁.inst a) (F₁.inst b') (f.app p) ∧
-    IH.TyDefEq (F₂.inst a) (F₂.inst b') (f.app p)) ∧
+    LRS.PiInstDefEq IH F₁ F₂ a b' (f.app p)) ∧
   ∀ {{a p}}, p.HasType b → Γ ⊢ a : B → IH.DefEq a a B p b →
     IH.TyDefEq (F₁.inst a) (F₂.inst a) (f.app p)
 
 theorem LRS.PiDefEq.left {IH : LogRel Γ n} :
     LRS.PiDefEq IH B F₁ F₂ b f → LRS.PiDefEq IH B F₁ F₁ b f := fun ⟨h1, _⟩ =>
-  ⟨fun _ _ _ hp ha a1 => ⟨(h1 hp ha a1).1, (h1 hp ha a1).1⟩, fun _ _ hp ha a1 => (h1 hp ha a1).1⟩
+  ⟨fun _ _ _ hp ha a1 =>
+      let h := h1 hp ha a1
+      ⟨h.leftTy, h.leftTy, h.leftDefEq, h.leftDefEq⟩,
+    fun _ _ hp ha a1 => (h1 hp ha a1).leftTy⟩
 
 def LRS.ValTyPi2 (IH : LogRel Γ n) (M₁ M₂ : SExpr) (b : WShape n) (f : WShapeFun n) : Prop :=
   ∃ B₁ F₁ B₂ F₂ u v,
     Γ ⊢ M₁ ⤳* .forallE B₁ F₁ ∧ Γ ⊢ M₂ ⤳* .forallE B₂ F₂ ∧
-    Γ ⊢ B₁ ≡ B₂ : .sort u ∧ B₁::Γ ⊢ F₁ ≡ F₂ : .sort v ∧ IH.TyDefEq B₁ B₂ b ∧
+    TypeDefEqPath Γ B₁ B₂ u ∧ TypeDefEqPath (B₁ :: Γ) F₁ F₂ v ∧
+    IH.TyDefEq B₁ B₂ b ∧
     LRS.PiDefEq IH B₁ F₁ F₂ b f
 
 def LRS.LamDefEq (IH : LogRel Γ n)
@@ -5409,19 +10314,1930 @@ theorem LRS.LamDefEq.mono_r_1 {IH : LogRel Γ n}
     have ht_cod := (WShape.HasTypePi.iff.1 hm'.1).2 x hx
     have hm_target := ht_cod.mono_r le_cod hg_p
   · have ⟨p1, p2⟩ := pav hax ha a1_down
-    have tyA₂ := (piEV.1 hx ha.hasType.1 (IH.left a1)).1
+    have tyA₂ := (piEV.1 hx ha.hasType.1 (IH.left a1)).leftTy
     exact ⟨IH.mono_r_1 le_cod hg_p hm_target tyA₂ (IH.mono_l h1 hg_p hg_x p1),
            IH.mono_r_1 le_cod hg_p hm_target tyA₂ (IH.mono_l h1 hg_p hg_x p2)⟩
   · have q := pae hax ha a1_down
     have tyA₂ := piEV.2 hx ha a1
     exact IH.mono_r_1 le_cod hg_p hm_target tyA₂ (IH.mono_l h1 hg_p hg_x q)
 
+/-! #### Observable inductive heads -/
+
+/-- A syntactic type realizes an inductive-type head when it weak-head reduces
+to a fully applied constant registered as an `indTy`. -/
+def LRS.IndTyHead (Γ : List SExpr) (A : SExpr) : Prop :=
+  ∃ (c : Name) (ls : List SLevel) (args : List SExpr),
+    Params.classify c = some (.indTy args.length) ∧
+    WHRedS Γ A (args.foldr (fun a f => f.app a) (.const c ls))
+
+theorem LRS.IndTyHead.whr (hA : WHRedS Γ A A') :
+    LRS.IndTyHead Γ A ↔ LRS.IndTyHead Γ A' := by
+  constructor
+  · rintro ⟨c, ls, args, hcl, rA⟩
+    exact ⟨c, ls, args, hcl, hA.determ_l rA (.indTy_spine hcl)⟩
+  · rintro ⟨c, ls, args, hcl, rA⟩
+    exact ⟨c, ls, args, hcl, .trans hA rA⟩
+
+theorem LRS.IndTyHead.not_sort : ¬LRS.IndTyHead Γ (.sort u) := by
+  rintro ⟨c, ls, args, _, rA⟩
+  have heq := WHNF.sort.whRedS rA
+  have hh := congrArg constHead? heq
+  simp only [constHead?, constHead?_spine] at hh
+  cases hh
+
+/-- Observable constructor-head evidence for a semantic element shape.  At
+bottom there is no observation; at a non-bottom constructor shape both the
+registered constructor name and the arity of its syntactic application spine
+must agree with the semantic head. -/
+def LRS.CtorHead (Γ : List SExpr) (M : SExpr) {n : Nat} (m : WShape (n+1)) : Prop :=
+  match m.1 with
+  | .bot => True
+  | .ctor c l =>
+    ∃ (ls : List SLevel) (args : List SExpr),
+      Params.classify c = some (.ctor args.length) ∧ args.length = l.length ∧
+      WHRedS Γ M (args.foldr (fun a f => f.app a) (.const c ls))
+  | _ => False
+
+@[simp] theorem LRS.CtorHead.bot : LRS.CtorHead Γ M (WShape.bot : WShape (n+1)) := by
+  trivial
+
+@[simp] theorem LRS.CtorHead.ctor {h : IsStruct c → WShape.ListNonZero l} :
+    LRS.CtorHead Γ M (WShape.ctor c l h) ↔
+      ∃ (ls : List SLevel) (args : List SExpr),
+        Params.classify c = some (.ctor args.length) ∧ args.length = l.length ∧
+        WHRedS Γ M (args.foldr (fun a f => f.app a) (.const c ls)) := by
+  simp only [LRS.CtorHead, WShape.ctor, List.length_map]
+
+theorem LRS.CtorHead.whr (hM : WHRedS Γ M M') :
+    LRS.CtorHead Γ M m ↔ LRS.CtorHead Γ M' m := by
+  cases m using WShape.casesOn' with
+  | ctor c l h =>
+    simp only [LRS.CtorHead.ctor]
+    constructor
+    · rintro ⟨ls, args, hcl, hlen, rM⟩
+      exact ⟨ls, args, hcl, hlen, hM.determ_l rM (.ctor_spine hcl)⟩
+    · rintro ⟨ls, args, hcl, hlen, rM⟩
+      exact ⟨ls, args, hcl, hlen, .trans hM rM⟩
+  | _ => rfl
+
+theorem LRS.CtorHead.mono_l (le : m ≤ m') (hm : m.HasType WShape.indTy) :
+    LRS.CtorHead Γ M m' → LRS.CtorHead Γ M m := by
+  cases m using WShape.casesOn' with
+  | bot => intro; trivial
+  | ctor c l h =>
+    rw [WShape.ctor_le] at le
+    obtain ⟨l', h', rfl, hll⟩ := le
+    simp only [LRS.CtorHead.ctor]
+    rintro ⟨ls, args, hcl, hlen, rM⟩
+    exact ⟨ls, args, hcl, hlen.trans hll.length_eq.symm, rM⟩
+  | _ => cases hm
+
+theorem LRS.CtorHead.lift {m : WShape (n+1)} (le : n ≤ n') :
+    LRS.CtorHead Γ M (m.lift (n'+1)) ↔ LRS.CtorHead Γ M m := by
+  cases m using WShape.casesOn' with
+  | bot => simp only [WShape.lift_bot, LRS.CtorHead.bot]
+  | sort r =>
+    change LRS.CtorHead Γ M ((WShape.sort r : WShape (n+1)).lift (n'+1)) ↔
+      LRS.CtorHead Γ M (WShape.sort r)
+    rw [WShape.lift_sort]
+    rfl
+  | forallE b f => rw [WShape.lift_forallE le]; simp [LRS.CtorHead, WShape.forallE]
+  | lam f h => rw [WShape.lift_lam le]; simp [LRS.CtorHead, WShape.lam]
+  | ctor c l h =>
+    rw [WShape.lift_ctor le]
+    simp only [LRS.CtorHead.ctor, List.length_map]
+  | indTy =>
+    change LRS.CtorHead Γ M ((WShape.indTy : WShape (n+1)).lift (n'+1)) ↔
+      LRS.CtorHead Γ M WShape.indTy
+    rw [WShape.lift_indTy]
+    rfl
+
+/-- A constructor application spine whose raw dependent typing and semantic
+field relation are one certificate.  Arguments and shapes are stored in
+newest-first order, matching `CtorArgsDefEq`; `cons` appends the displayed
+argument to the actual left-to-right application spine.  The final equality
+records the dependent codomain transport from the right argument back to the
+left-oriented result, which makes reflexive and symmetric observations
+structural rather than dependent on type uniqueness. -/
+inductive LRS.CtorSpineDefEq (IH : LogRel Γ n) (Head : SExpr) :
+    List SExpr → List SExpr → List (WShape n) → SExpr → Prop where
+  | nil : CtorSpineDefEq IH Head [] [] [] Head
+  | cons
+      (hrest : CtorSpineDefEq IH Head xs ys ps A)
+      (hPi : IsDefEq Γ A (.forallE D C) (.sort u))
+      (hp : p.HasType a)
+      (hty : IH.TyDefEq D D a)
+      (hxy : IsDefEq Γ x y D)
+      (hv : IH.DefEq x y D p a)
+      (hresult : IsDefEq Γ (C.inst y) (C.inst x) (.sort v)) :
+      CtorSpineDefEq IH Head (x :: xs) (y :: ys) (p :: ps) (C.inst x)
+  | ret
+      (hrest : CtorSpineDefEq IH Head xs ys ps A)
+      (hresult : IsDefEq Γ A A' (.sort u)) :
+      CtorSpineDefEq IH Head xs ys ps A'
+
+/-- Relational evidence for the fields of one constructor application spine.
+Besides the lower-level logical-relation witness, each field retains the raw
+typed equality used to build a concrete proof-carrying pattern action. -/
+inductive LRS.CtorArgsDefEq (IH : LogRel Γ n) :
+    List SExpr → List SExpr → List (WShape n) → Prop where
+  | nil : CtorArgsDefEq IH [] [] []
+  | cons (hp : p.HasType a) (hty : IH.TyDefEq A A a)
+      (hxy : Γ ⊢ x ≡ y : A)
+      (hv : IH.DefEq x y A p a) (hrest : CtorArgsDefEq IH xs ys ps) :
+      CtorArgsDefEq IH (x :: xs) (y :: ys) (p :: ps)
+
+/-- The level-indexed uniqueness fragment needed when two exact constructor
+observations share a middle field.  It does not assert unrestricted
+faithfulness of the logical relation: both typings and both semantic
+validity witnesses for the *same term and shape* are supplied.  The result
+aligns the raw field types and their semantic type interpretations, exactly
+the two conversions required by dependent constructor-spine composition.
+
+In the joint L4L-16 proof this package is not derivable from same-level
+adequacy alone: bottom shapes erase weak typing evidence, and weak judgments
+require a well-formed target context.  The sound tower first establishes
+adequacy at positive level one, uses its sort/Pi observations and context
+validity to obtain the level-zero package, and thereafter constructs
+successor packages in the offset order recorded by `LR.JointBuilder`.
+Constructor composition in `LRS` consumes the predecessor package. -/
+structure LogRel.LimitedUniq (IH : LogRel Γ n) : Prop where
+  align : ∀ {x A B : SExpr} {p a b : WShape n},
+    p.HasType a → p.HasType b →
+    IsDefEq Γ x x A → IsDefEq Γ x x B →
+    IH.TyDefEq A A a → IH.TyDefEq B B b →
+    IH.DefEq x x A p a → IH.DefEq x x B p b →
+    ∃ u, IsDefEq Γ A B (.sort u) ∧
+      ∀ {y : SExpr}, IsDefEq Γ x y B → IH.DefEq x y B p b →
+        IH.DefEq x y A p a
+
+/-- Retype all three edges of a result rectangle in lockstep.
+
+The two target self-relations are explicit because `LimitedUniq` is
+term-indexed: the left and right heads may justify the target observation by
+different typing derivations.  The diagonal deliberately reuses the left
+head's transport, which preserves the left-oriented dependent result type
+used by application congruence. -/
+theorem LogRel.DefEqRect.retype_of_limitedUniq
+    {R : LogRel Γ n} (uniq : LogRel.LimitedUniq R)
+    {M₁ M₂ N₁ N₂ A B : SExpr} {p a b : WShape n}
+    (hpA : p.HasType a) (hpB : p.HasType b)
+    (hM₁A : IsDefEq Γ M₁ M₁ A)
+    (hN₁A : IsDefEq Γ N₁ N₁ A)
+    (hA : R.TyDefEq A A a) (hB : R.TyDefEq B B b)
+    (hM₁rel : R.DefEq M₁ M₁ A p a)
+    (hN₁rel : R.DefEq N₁ N₁ A p a)
+    (hleft : IsDefEq Γ M₁ M₂ B)
+    (hright : IsDefEq Γ N₁ N₂ B)
+    (hcross : IsDefEq Γ M₁ N₂ B)
+    (H : LogRel.DefEqRect R M₁ M₂ N₁ N₂ B p b) :
+    LogRel.DefEqRect R M₁ M₂ N₁ N₂ A p a := by
+  obtain ⟨_, _, retypeLeft⟩ := uniq.align hpA hpB
+    hM₁A hleft.hasType.1 hA hB hM₁rel (R.left H.left)
+  obtain ⟨_, _, retypeRight⟩ := uniq.align hpA hpB
+    hN₁A hright.hasType.1 hA hB hN₁rel (R.left H.right)
+  exact ⟨retypeLeft hleft H.left,
+    retypeRight hright H.right,
+    retypeLeft hcross H.cross⟩
+
+/-- Raw weak type uniqueness in one target context.  This is separated from
+`LimitedUniq`: the latter additionally transports semantic witnesses between
+the two type shapes, while this proposition is exactly the former L4L-17
+co-deliverable derived from the level-zero stratified-inversion bootstrap. -/
+def LogRel.RawTypeUniq (Γ : List SExpr) : Prop :=
+  ∀ {x A B : SExpr}, IsDefEq Γ x x A → IsDefEq Γ x x B →
+    ∃ u, IsDefEq Γ A B (.sort u)
+
+/-- Raw type uniqueness uniformly over well-formed target contexts.  Binder
+inversion needs this contextual form: after aligning a Pi domain it consumes
+the same theorem once more in the extended context. -/
+def LogRel.ContextualRawTypeUniq : Prop :=
+  ∀ {Γ : List SExpr}, Ctx.WF Γ → LogRel.RawTypeUniq Γ
+
+/-- Collapse a heterogeneous type-equality path once ordinary type
+uniqueness is available in its context.  At a concatenation point,
+uniqueness aligns the two universe assignments for the shared type before
+the raw equalities are composed. -/
+theorem TypeDefEqPath.collapse
+    (uniq : LogRel.RawTypeUniq Γ)
+    (H : TypeDefEqPath Γ A B u) : IsDefEq Γ A B (.sort u) := by
+  induction H with
+  | single h => exact h
+  | trans _ _ ih₁ ih₂ =>
+    obtain ⟨_, huv⟩ := uniq ih₁.hasType.2 ih₂.hasType.1
+    exact ih₁.trans (huv.symm.defeqDF ih₂)
+
+/-- At the bottom stratum, limited semantic uniqueness has no additional
+content beyond raw weak type uniqueness.  A non-bottom element shape is a
+sort and therefore fixes its type shape; at bottom, both term relations are
+definitionally trivial.  This is the semantic half of the positive
+level-one bootstrap used after the path-valued positive-adequacy argument
+derives contextual raw type uniqueness. -/
+theorem LR0.limitedUniq_of_typeUniq
+    (typeUniq : LogRel.RawTypeUniq Γ) :
+    LogRel.LimitedUniq (LR0 : LogRel Γ 0) where
+  align := by
+    intro x A B p a b hpA hpB hxA hxB _ _ _ _
+    obtain ⟨u, hAB⟩ := typeUniq hxA hxB
+    refine ⟨u, hAB, ?_⟩
+    intro y _ hxy
+    cases p using WShape.casesOn with
+    | bot =>
+      simp only [LR0, LR0.DefEq, LR0.TyDefEq]
+      split <;> trivial
+    | sort r =>
+      cases hpA.unfold
+      cases hpB.unfold
+      exact hxy
+
+/-- Forget the dependent constructor telescope while retaining its aligned
+per-field logical-relation evidence. -/
+theorem LRS.CtorSpineDefEq.args
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    CtorArgsDefEq IH xs ys ps := by
+  induction H with
+  | nil => exact .nil
+  | cons _ _ hp hty hxy hv _ ih => exact .cons hp hty hxy hv ih
+  | ret _ _ ih => exact ih
+
+/-- Forget semantic fields while retaining the exact dependent pointwise
+application spine. -/
+theorem LRS.CtorSpineDefEq.spine
+    {Γ : List SExpr} {n : Nat} {IH : LogRel Γ n}
+    {Head A : SExpr} {xs ys : List SExpr} {ps : List (WShape n)}
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    SExpr.SpineDefEq Γ Head xs.reverse ys.reverse A := by
+  induction H with
+  | nil => exact .nil
+  | cons _ hPi _ _ hxy _ _ ih =>
+    simpa only [List.reverse_cons] using ih.snoc hPi hxy
+  | ret _ hresult ih => exact .ret ih hresult
+
+/-- Keep the left constructor application at both endpoints. -/
+theorem LRS.CtorSpineDefEq.left
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    CtorSpineDefEq IH Head xs xs ps A := by
+  induction H with
+  | nil => exact .nil
+  | cons _ hPi hp hty hxy hv hresult ih =>
+    exact .cons ih hPi hp hty hxy.hasType.1 (IH.left hv)
+      (hresult.symm.trans hresult)
+  | ret _ hresult ih => exact .ret ih hresult
+
+/-- Keep the right constructor application at both endpoints while
+transporting its dependent result back to the original left-oriented type. -/
+theorem LRS.CtorSpineDefEq.right
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    CtorSpineDefEq IH Head ys ys ps A := by
+  induction H with
+  | nil => exact .nil
+  | cons _ hPi hp hty hxy hv hresult ih =>
+    exact .ret
+      (.cons ih hPi hp hty hxy.hasType.2 (IH.left (IH.symm hv))
+        (hresult.trans hresult.symm))
+      hresult
+  | ret _ hresult ih => exact .ret ih hresult
+
+/-- Keep the final argument pair while using the left dependent prefix at
+both endpoints.  Constructor spines are stored newest-first, so after the
+outer result conversions have been crossed the displayed `cons` is exactly
+the final application and its recursive tail is the prefix to duplicate. -/
+theorem LRS.CtorSpineDefEq.leftPrefixes
+    (H : CtorSpineDefEq IH Head (x :: xs) (y :: ys) (p :: ps) A) :
+    CtorSpineDefEq IH Head (x :: xs) (y :: xs) (p :: ps) A := by
+  generalize hx : x :: xs = xs' at H
+  generalize hy : y :: ys = ys' at H
+  generalize hp : p :: ps = ps' at H
+  induction H generalizing x xs y ys p ps with
+  | nil => simp at hx
+  | cons hrest hPi hpty hty hxy hrel hresult ih =>
+    simp only [List.cons.injEq] at hx hy hp
+    rcases hx with ⟨rfl, rfl⟩
+    rcases hy with ⟨rfl, rfl⟩
+    rcases hp with ⟨rfl, rfl⟩
+    exact .cons hrest.left hPi hpty hty hxy hrel hresult
+  | ret hrest hresult ih =>
+    exact .ret (ih hx hy hp) hresult
+
+/-- Keep the final argument pair while using the right dependent prefix at
+both endpoints. -/
+theorem LRS.CtorSpineDefEq.rightPrefixes
+    (H : CtorSpineDefEq IH Head (x :: xs) (y :: ys) (p :: ps) A) :
+    CtorSpineDefEq IH Head (x :: ys) (y :: ys) (p :: ps) A := by
+  generalize hx : x :: xs = xs' at H
+  generalize hy : y :: ys = ys' at H
+  generalize hp : p :: ps = ps' at H
+  induction H generalizing x xs y ys p ps with
+  | nil => simp at hx
+  | cons hrest hPi hpty hty hxy hrel hresult ih =>
+    simp only [List.cons.injEq] at hx hy hp
+    rcases hx with ⟨rfl, rfl⟩
+    rcases hy with ⟨rfl, rfl⟩
+    rcases hp with ⟨rfl, rfl⟩
+    exact .cons hrest.right hPi hpty hty hxy hrel hresult
+  | ret hrest hresult ih =>
+    exact .ret (ih hx hy hp) hresult
+
+/-- Swap the two concrete constructor spines without changing the
+left-oriented final result type. -/
+theorem LRS.CtorSpineDefEq.symm
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    CtorSpineDefEq IH Head ys xs ps A := by
+  induction H with
+  | nil => exact .nil
+  | cons _ hPi hp hty hxy hv hresult ih =>
+    exact .ret
+      (.cons ih hPi hp hty hxy.symm (IH.symm hv) hresult.symm)
+      hresult
+  | ret _ hresult ih => exact .ret ih hresult
+
+/-- Rebase every semantic field while preserving the same raw dependent
+constructor telescope. -/
+theorem LRS.CtorSpineDefEq.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a))
+    (H : CtorSpineDefEq IH Head xs ys ps A) :
+    CtorSpineDefEq IH' Head xs ys (ps.map (.lift n')) A := by
+  induction H with
+  | nil => exact .nil
+  | cons _ hPi hp hty hxy hv hresult ih =>
+    exact .cons ih hPi ((WShape.HasType.lift le).2 hp)
+      ((hliftTy hp.isType).2 hty) hxy ((hlift hp).2 hv) hresult
+  | ret _ hresult ih => exact .ret ih hresult
+
+theorem LRS.CtorArgsDefEq.lengths
+    (H : CtorArgsDefEq IH xs ys ps) :
+    xs.length = ps.length ∧ ys.length = ps.length := by
+  induction H with
+  | nil => exact ⟨rfl, rfl⟩
+  | cons _ _ _ _ _ ih =>
+    exact ⟨congrArg Nat.succ ih.1, congrArg Nat.succ ih.2⟩
+
+/-- Drop the newest related constructor field. -/
+theorem LRS.CtorArgsDefEq.tail
+    (H : CtorArgsDefEq IH (x :: xs) (y :: ys) (p :: ps)) :
+    CtorArgsDefEq IH xs ys ps := by
+  cases H with
+  | cons _ _ _ _ hrest => exact hrest
+
+/-- Compose adjacent exact constructor-field bundles using only the
+level-indexed uniqueness fragment.  The output is left-oriented: its raw
+and semantic equalities retain the first link's field type. -/
+theorem LRS.CtorArgsDefEq.trans
+    (uniq : LogRel.LimitedUniq IH)
+    (H₁ : CtorArgsDefEq IH xs ys ps)
+    (H₂ : CtorArgsDefEq IH ys zs ps) :
+    CtorArgsDefEq IH xs zs ps := by
+  induction H₁ generalizing zs with
+  | nil =>
+    cases H₂
+    exact .nil
+  | cons hp htyA hxy hvxy hrest ih =>
+    cases H₂ with
+    | cons hpB htyB hyz hvyz hrest₂ =>
+      have hyyA := hxy.hasType.2
+      have hyyB := hyz.hasType.1
+      have vyyA := IH.left (IH.symm hvxy)
+      have vyyB := IH.left hvyz
+      obtain ⟨_, hAB, retype⟩ :=
+        uniq.align hp hpB hyyA hyyB htyA htyB vyyA vyyB
+      have hyzA := IsDefEq.defeqDF hAB.symm hyz
+      have vyzA := retype hyz hvyz
+      exact .cons hp htyA (hxy.trans hyzA) (IH.trans hvxy vyzA)
+        (ih hrest₂)
+
+theorem LRS.CtorArgsDefEq.left
+    (H : CtorArgsDefEq IH xs ys ps) : CtorArgsDefEq IH xs xs ps := by
+  induction H with
+  | nil => exact .nil
+  | cons hp hty hxy hv _ ih =>
+    exact .cons hp hty hxy.hasType.1 (IH.left hv) ih
+
+theorem LRS.CtorArgsDefEq.right
+    (H : CtorArgsDefEq IH xs ys ps) : CtorArgsDefEq IH ys ys ps := by
+  induction H with
+  | nil => exact .nil
+  | cons hp hty hxy hv _ ih =>
+    exact .cons hp hty hxy.hasType.2 (IH.left (IH.symm hv)) ih
+
+theorem LRS.CtorArgsDefEq.symm
+    (H : CtorArgsDefEq IH xs ys ps) : CtorArgsDefEq IH ys xs ps := by
+  induction H with
+  | nil => exact .nil
+  | cons hp hty hxy hv _ ih =>
+    exact .cons hp hty hxy.symm (IH.symm hv) ih
+
+theorem LRS.CtorArgsDefEq.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a))
+    (H : CtorArgsDefEq IH xs ys ps) :
+    CtorArgsDefEq IH' xs ys (ps.map (.lift n')) := by
+  induction H with
+  | nil => exact .nil
+  | cons hp hty hxy hv _ ih =>
+    exact .cons ((WShape.HasType.lift le).2 hp)
+      ((hliftTy hp.isType).2 hty) hxy ((hlift hp).2 hv) ih
+
+/-- Constructor observations, freely closed under the structural laws of a
+logical relation.  The explicit `lift`/`unlift` constructors are important:
+a high-level constructor field can contain refinements with no well-formed
+projection at a lower shape level.  Retaining the original finite evidence
+avoids the invalid general `Shape.WF.plift` principle while still exposing an
+exact constructor spine at the leaves consumed by pattern adequacy. -/
+inductive LRS.CtorDefEq (Γ : List SExpr) :
+    {n : Nat} → LogRel Γ n → SExpr → SExpr → WShape (n + 1) → Prop where
+  | exact {IH : LogRel Γ n} {c : Name} {rargs : List (WShape n)} {hwf}
+      {M N : SExpr} {ls ls' : List SLevel} {args args' : List SExpr}
+      {CHead CHead' A A' : SExpr} :
+      Params.classify c = some (.ctor args.length) →
+      args.length = rargs.length → args'.length = rargs.length →
+      ls = ls' →
+      WHRedS Γ M (args.foldr (fun a f => f.app a) (.const c ls)) →
+      WHRedS Γ N (args'.foldr (fun a f => f.app a) (.const c ls')) →
+      IsDefEq Γ (.const c ls) (.const c ls) CHead →
+      IsDefEq Γ (.const c ls') (.const c ls') CHead' →
+      SExpr.SpineWF Γ CHead args.reverse A →
+      SExpr.SpineWF Γ CHead' args'.reverse A' →
+      CtorArgsDefEq IH args args' rargs →
+      CtorSpineDefEq IH CHead args args' rargs A →
+      CtorSpineDefEq IH CHead' args' args rargs A' →
+      CtorDefEq Γ IH M N (.ctor c rargs.reverse hwf)
+  | left : CtorDefEq Γ IH M N m → CtorDefEq Γ IH M M m
+  | symm : CtorDefEq Γ IH M N m → CtorDefEq Γ IH N M m
+  | trans : CtorDefEq Γ IH M N m → CtorDefEq Γ IH N P m →
+      CtorDefEq Γ IH M P m
+  | mono : m ≤ m' → CtorDefEq Γ IH M N m' → CtorDefEq Γ IH M N m
+  | whr : WHRedS Γ M M' → WHRedS Γ N N' → CtorDefEq Γ IH M N m →
+      CtorDefEq Γ IH M' N' m
+  | unwhr : WHRedS Γ M M' → WHRedS Γ N N' → CtorDefEq Γ IH M' N' m →
+      CtorDefEq Γ IH M N m
+  | lift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+        (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+      (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+        (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+      CtorDefEq Γ IH M N m → CtorDefEq Γ IH' M N (m.lift (n' + 1))
+  | unlift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+        (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+      (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+        (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+      CtorDefEq Γ IH' M N (m.lift (n' + 1)) → CtorDefEq Γ IH M N m
+
+theorem LRS.CtorDefEq.whr_iff
+    (hM : WHRedS Γ M M') (hN : WHRedS Γ N N') :
+    LRS.CtorDefEq Γ IH M N m ↔ LRS.CtorDefEq Γ IH M' N' m :=
+  ⟨.whr hM hN, .unwhr hM hN⟩
+
+theorem LRS.CtorDefEq.lift_iff {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+    (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+    LRS.CtorDefEq Γ IH' M N (m.lift (n' + 1)) ↔
+      LRS.CtorDefEq Γ IH M N m :=
+  ⟨.unlift le hliftTy hlift, .lift le hliftTy hlift⟩
+
+/-- An explicit equivalence between a logical relation and its realization
+at a higher shape level.  `CtorDefEq` exposes these two clauses separately;
+packaging them makes the target-level continuation used by its fold
+composable. -/
+structure LogRel.LiftEquiv
+    (IH : LogRel Γ n) (IH' : LogRel Γ n') (le : n ≤ n') : Prop where
+  ty : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+    (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a)
+  term : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+    (IH'.DefEq M N A (m.lift n') (a.lift n') ↔
+      IH.DefEq M N A m a)
+
+/-- The two transport clauses supplied by a `CtorDefEq` lift constructor. -/
+def LogRel.LiftEquiv.ofFields
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔
+        IH.DefEq M N A m a)) :
+    LogRel.LiftEquiv IH IH' le := ⟨hliftTy, hlift⟩
+
+/-- Every relation is trivially equivalent to itself at the same level. -/
+def LogRel.LiftEquiv.refl (IH : LogRel Γ n) :
+    LogRel.LiftEquiv IH IH (Nat.le_refl n) where
+  ty := by
+    intro A B a ha
+    simp only [WShape.lift_self]
+  term := by
+    intro M N A m a hma
+    simp only [WShape.lift_self]
+
+/-- Rebase a synchronized rectangle through a logical-relation lift
+equivalence.  The iff is intentionally restricted to observations lifted
+from the lower endpoint; it makes no projection claim about arbitrary
+higher-level refinements. -/
+theorem LogRel.LiftEquiv.rect
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} {le : n ≤ n'}
+    (E : LogRel.LiftEquiv IH IH' le) (hma : m.HasType a) :
+    LogRel.DefEqRect IH' M₁ M₂ N₁ N₂ A
+        (m.lift n') (a.lift n') ↔
+      LogRel.DefEqRect IH M₁ M₂ N₁ N₂ A m a := by
+  constructor
+  · intro H
+    exact ⟨(E.term hma).1 H.left,
+      (E.term hma).1 H.right,
+      (E.term hma).1 H.cross⟩
+  · intro H
+    exact ⟨(E.term hma).2 H.left,
+      (E.term hma).2 H.right,
+      (E.term hma).2 H.cross⟩
+
+/-- Lift equivalences compose without exposing any high-level refinements at
+the lower endpoint. -/
+theorem LogRel.LiftEquiv.trans
+    {IH₀ : LogRel Γ n₀} {IH₁ : LogRel Γ n₁}
+    {IH₂ : LogRel Γ n₂} {le₀₁ : n₀ ≤ n₁} {le₁₂ : n₁ ≤ n₂}
+    (H₀₁ : LogRel.LiftEquiv IH₀ IH₁ le₀₁)
+    (H₁₂ : LogRel.LiftEquiv IH₁ IH₂ le₁₂) :
+    LogRel.LiftEquiv IH₀ IH₂ (Nat.le_trans le₀₁ le₁₂) where
+  ty := by
+    intro A B a ha
+    have ha' : (a.lift n₁).HasType .type := by
+      simpa only [WShape.lift_type] using
+        (WShape.HasType.lift le₀₁).2 ha
+    rw [← WShape.lift_lift (s := a) (.inl le₀₁)]
+    exact (H₁₂.ty ha').trans
+      (H₀₁.ty ha)
+  term := by
+    intro M N A m a hma
+    rw [← WShape.lift_lift (s := m) (.inl le₀₁),
+      ← WShape.lift_lift (s := a) (.inl le₀₁)]
+    exact (H₁₂.term ((WShape.HasType.lift le₀₁).2 hma)).trans
+      (H₀₁.term hma)
+
+/-- Cancel a common higher realization on shapes that originate at the
+lowest relation.  This is deliberately weaker than projecting arbitrary
+`IH₁` refinements: the only queried `IH₁` shapes are lifts of `IH₀`
+shapes.  That restriction is what makes the operation valid and is the
+transport law used by the `.lift` branch of a target-level continuation. -/
+theorem LogRel.LiftEquiv.cancelRight
+    {IH₀ : LogRel Γ n₀} {IH₁ : LogRel Γ n₁}
+    {IH₂ : LogRel Γ n₂} {le₀₁ : n₀ ≤ n₁} {le₁₂ : n₁ ≤ n₂}
+    (H₀₂ : LogRel.LiftEquiv IH₀ IH₂ (Nat.le_trans le₀₁ le₁₂))
+    (H₁₂ : LogRel.LiftEquiv IH₁ IH₂ le₁₂) :
+    LogRel.LiftEquiv IH₀ IH₁ le₀₁ where
+  ty := by
+    intro A B a ha
+    have ha₁ : (a.lift n₁).HasType .type := by
+      simpa only [WShape.lift_type] using
+        (WShape.HasType.lift le₀₁).2 ha
+    have hhigh := H₁₂.ty (A := A) (B := B) ha₁
+    rw [WShape.lift_lift (s := a) (.inl le₀₁)] at hhigh
+    exact hhigh.symm.trans (H₀₂.ty ha)
+  term := by
+    intro M N A m a hma
+    have hhigh := H₁₂.term (M := M) (N := N) (A := A)
+      ((WShape.HasType.lift le₀₁).2 hma)
+    rw [WShape.lift_lift (s := m) (.inl le₀₁),
+      WShape.lift_lift (s := a) (.inl le₀₁)] at hhigh
+    exact hhigh.symm.trans (H₀₂.term hma)
+
+/-- Rebase a related constructor spine through a packaged lift
+equivalence. -/
+theorem LRS.CtorArgsDefEq.rebase
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} {le : n ≤ n'}
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorArgsDefEq IH xs ys ps) :
+    LRS.CtorArgsDefEq IH' xs ys (ps.map (.lift n')) :=
+  H.lift le E.ty E.term
+
+/-- A unary transport context from a native exact constructor observation
+back to the logical relation and shape requested at the root.  In
+particular, an `unlift` frame retains its high-level evidence instead of
+projecting arbitrary higher-level constructor fields. -/
+inductive LRS.CtorFrame (Γ : List SExpr) :
+    {n k : Nat} → LogRel Γ n → WShape (n + 1) →
+      LogRel Γ k → WShape (k + 1) → Prop where
+  | refl : CtorFrame Γ IH m IH m
+  | mono : m ≤ m' → CtorFrame Γ IH m' J p → CtorFrame Γ IH m J p
+  | lift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (E : LogRel.LiftEquiv IH IH' le) :
+      CtorFrame Γ IH m J p →
+      CtorFrame Γ IH' (m.lift (n' + 1)) J p
+  | unlift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (E : LogRel.LiftEquiv IH IH' le) :
+      CtorFrame Γ IH' (m.lift (n' + 1)) J p →
+      CtorFrame Γ IH m J p
+
+/-- Reapply a constructor transport frame to native evidence. -/
+theorem LRS.CtorFrame.apply
+    (F : LRS.CtorFrame Γ IH m J p)
+    (H : LRS.CtorDefEq Γ J M N p) :
+    LRS.CtorDefEq Γ IH M N m := by
+  induction F with
+  | refl => exact H
+  | mono hle _ ih => exact .mono hle (ih H)
+  | lift le E _ ih => exact .lift le E.ty E.term (ih H)
+  | unlift le E _ ih => exact .unlift le E.ty E.term (ih H)
+
+/-- One native, exact constructor-spine observation.  Endpoint weak-head
+reductions live in `CtorView`; this certificate contains only the finite
+head, telescope, and field payload of the exact leaf. -/
+inductive LRS.CtorExact (Γ : List SExpr) :
+    {n : Nat} → LogRel Γ n → SExpr → SExpr → WShape (n + 1) → Prop where
+  | intro {IH : LogRel Γ n} {c : Name} {rargs : List (WShape n)} {hwf}
+      {ls ls' : List SLevel} {args args' : List SExpr}
+      {CHead CHead' A A' : SExpr} :
+      Params.classify c = some (.ctor args.length) →
+      args.length = rargs.length → args'.length = rargs.length →
+      ls = ls' →
+      IsDefEq Γ (.const c ls) (.const c ls) CHead →
+      IsDefEq Γ (.const c ls') (.const c ls') CHead' →
+      SExpr.SpineWF Γ CHead args.reverse A →
+      SExpr.SpineWF Γ CHead' args'.reverse A' →
+      LRS.CtorArgsDefEq IH args args' rargs →
+      LRS.CtorSpineDefEq IH CHead args args' rargs A →
+      LRS.CtorSpineDefEq IH CHead' args' args rargs A' →
+      CtorExact Γ IH
+        (args.foldr (fun a f => f.app a) (.const c ls))
+        (args'.foldr (fun a f => f.app a) (.const c ls'))
+        (.ctor c rargs.reverse hwf)
+
+/-- Reconstitute the free relation's exact constructor from a normalized
+native leaf. -/
+theorem LRS.CtorExact.toCtorDefEq
+    (H : LRS.CtorExact Γ IH M N m) :
+    LRS.CtorDefEq Γ IH M N m := by
+  cases H with
+  | intro hcl hlen hlen' hlevels hhead hhead' hspine hspine' hargs haligned hmirror =>
+    exact .exact hcl hlen hlen' hlevels .rfl .rfl hhead hhead' hspine hspine'
+      hargs haligned hmirror
+
+/-- Mirror one exact native link. -/
+theorem LRS.CtorExact.symm
+    (H : LRS.CtorExact Γ IH M N m) :
+    LRS.CtorExact Γ IH N M m := by
+  cases H with
+  | @intro c rargs hwf ls ls' args args' CHead CHead' A A'
+      hcl hlen hlen' hlevels hhead hhead' hspine hspine' hargs haligned hmirror =>
+    have hcl' : Params.classify c = some (.ctor args'.length) := by
+      simpa [hlen, hlen'] using hcl
+    exact .intro hcl' hlen' hlen hlevels.symm hhead' hhead hspine' hspine
+      hargs.symm hmirror haligned
+
+/-- Every native constructor link retains an ordinary typed equality of its
+two concrete spines.  The result type is intentionally existential: adjacent
+links may expose different telescope result types, and the normalized-chain
+consumer aligns those types only after choosing the recursor domain at the
+root. -/
+theorem LRS.CtorExact.rawDefEq
+    (H : LRS.CtorExact Γ IH M N m) :
+    ∃ A, IsDefEq Γ M N A := by
+  cases H with
+  | @intro c rargs hwf ls ls' args args' CHead CHead' A A'
+      hcl hlen hlen' hlevels hhead hhead' hspine hspine' hargs haligned hmirror =>
+    subst ls'
+    refine ⟨A, ?_⟩
+    simpa only [List.foldl_reverse] using haligned.spine.congr hhead
+
+/-- A term anchored to a classified constructor spine. -/
+inductive LRS.CtorView (Γ : List SExpr) (M : SExpr) : SExpr → Prop where
+  | intro {c : Name} {ls : List SLevel} {args : List SExpr} :
+      Params.classify c = some (.ctor args.length) →
+      WHRedS Γ M (args.foldr (fun a f => f.app a) (.const c ls)) →
+      CtorView Γ M (args.foldr (fun a f => f.app a) (.const c ls))
+
+/-- Move a constructor view forward along a weak-head reduction. -/
+theorem LRS.CtorView.whr
+    (hM : WHRedS Γ M M') (V : LRS.CtorView Γ M X) :
+    LRS.CtorView Γ M' X := by
+  cases V with
+  | intro hcl hred =>
+    exact .intro hcl (hM.determ_l hred (.ctorSpine hcl _))
+
+/-- Move a constructor view backward along a weak-head reduction. -/
+theorem LRS.CtorView.unwhr
+    (hM : WHRedS Γ M M') (V : LRS.CtorView Γ M' X) :
+    LRS.CtorView Γ M X := by
+  cases V with
+  | intro hcl hred => exact .intro hcl (.trans hM hred)
+
+/-- A normalized link: one native exact leaf plus its transport frame back
+to the root relation. -/
+inductive LRS.CtorLink (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) : SExpr → SExpr → Prop where
+  | intro (frame : LRS.CtorFrame Γ IH m J p)
+      (exact : LRS.CtorExact Γ J X Y p) : CtorLink Γ IH m X Y
+
+theorem LRS.CtorLink.toCtorDefEq
+    (H : LRS.CtorLink Γ IH m X Y) :
+    LRS.CtorDefEq Γ IH X Y m := by
+  cases H with
+  | intro frame exact => exact frame.apply exact.toCtorDefEq
+
+theorem LRS.CtorLink.symm
+    (H : LRS.CtorLink Γ IH m X Y) :
+    LRS.CtorLink Γ IH m Y X := by
+  cases H with
+  | intro frame exact => exact .intro frame exact.symm
+
+/-- Frames change only the semantic relation and observation shape; the raw
+typed equality carried by the native leaf is unchanged. -/
+theorem LRS.CtorLink.rawDefEq
+    (H : LRS.CtorLink Γ IH m X Y) :
+    ∃ A, IsDefEq Γ X Y A := by
+  cases H with
+  | intro _ exact => exact exact.rawDefEq
+
+theorem LRS.CtorLink.mono (hle : m' ≤ m)
+    (H : LRS.CtorLink Γ IH m X Y) :
+    LRS.CtorLink Γ IH m' X Y := by
+  cases H with
+  | intro frame exact => exact .intro (.mono hle frame) exact
+
+theorem LRS.CtorLink.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorLink Γ IH m X Y) :
+    LRS.CtorLink Γ IH' (m.lift (n' + 1)) X Y := by
+  cases H with
+  | intro frame exact => exact .intro (.lift le E frame) exact
+
+theorem LRS.CtorLink.unlift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorLink Γ IH' (m.lift (n' + 1)) X Y) :
+    LRS.CtorLink Γ IH m X Y := by
+  cases H with
+  | intro frame exact => exact .intro (.unlift le E frame) exact
+
+/-- A nonempty sequence of native exact links.  All free structural closure
+has been pushed into link frames or into the sequence itself. -/
+inductive LRS.CtorPath (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) : SExpr → SExpr → Prop where
+  | single : LRS.CtorLink Γ IH m X Y → CtorPath Γ IH m X Y
+  | cons : LRS.CtorLink Γ IH m X Y → CtorPath Γ IH m Y Z →
+      CtorPath Γ IH m X Z
+
+theorem LRS.CtorPath.toCtorDefEq
+    (H : LRS.CtorPath Γ IH m X Y) :
+    LRS.CtorDefEq Γ IH X Y m := by
+  induction H with
+  | single link => exact link.toCtorDefEq
+  | cons link _ ih => exact link.toCtorDefEq.trans ih
+
+/-- Retype and compose a normalized constructor path at one externally
+chosen domain.  Only raw type uniqueness is needed: each native link already
+carries its own typed equality, and the right endpoint of a retyped link is
+the typed anchor for the remainder of the path.
+
+This is the raw half of the joint L4L-16/17 chain consumer.  Weak-head
+subject reduction is deliberately absent here; it is needed only to provide
+the first root-to-view anchor consumed by `CtorChain.rawDefEqAt`. -/
+theorem LRS.CtorPath.rawDefEqAt
+    (uniq : LogRel.RawTypeUniq Γ)
+    (H : LRS.CtorPath Γ IH m X Y)
+    (hX : IsDefEq Γ X X D) :
+    IsDefEq Γ X Y D := by
+  induction H with
+  | single link =>
+    obtain ⟨A, hXY⟩ := link.rawDefEq
+    obtain ⟨_, hAD⟩ := uniq hXY.hasType.1 hX
+    exact hAD.defeqDF hXY
+  | cons link rest ih =>
+    obtain ⟨A, hXY⟩ := link.rawDefEq
+    obtain ⟨_, hAD⟩ := uniq hXY.hasType.1 hX
+    have hXYD : IsDefEq Γ _ _ D := hAD.defeqDF hXY
+    exact hXYD.trans (ih hXYD.hasType.2)
+
+/-- A native-path consumer that receives every exact link already retyped at
+one common root domain.  This is stronger than `CtorChain.Algebra.exact` in
+exactly one controlled way: raw uniqueness is used by `foldRaw` before the
+handler runs, so the handler never has to reconcile telescope result types
+or manufacture typing for a shared midpoint. -/
+structure LRS.CtorPath.RawAlgebra (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) (D : SExpr) (Q : SExpr → SExpr → Prop) where
+  exact : ∀ {k : Nat} {J : LogRel Γ k} {p : WShape (k + 1)} {X Y : SExpr},
+    LRS.CtorFrame Γ IH m J p → LRS.CtorExact Γ J X Y p →
+    IsDefEq Γ X Y D → Q X Y
+  trans : ∀ {X Y Z : SExpr}, Q X Y → Q Y Z → Q X Z
+
+/-- Fold a normalized path while threading the common-domain self-typing of
+its current vertex.  Each exact leaf is retyped once; its right endpoint then
+anchors the recursive tail. -/
+theorem LRS.CtorPath.foldRaw
+    (uniq : LogRel.RawTypeUniq Γ)
+    (alg : LRS.CtorPath.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorPath Γ IH m X Y)
+    (hX : IsDefEq Γ X X D) : Q X Y := by
+  induction H with
+  | single link =>
+    cases link with
+    | intro frame leaf =>
+      obtain ⟨A, hXY⟩ := leaf.rawDefEq
+      obtain ⟨_, hAD⟩ := uniq hXY.hasType.1 hX
+      exact alg.exact frame leaf (hAD.defeqDF hXY)
+  | cons link rest ih =>
+    cases link with
+    | intro frame leaf =>
+      obtain ⟨A, hXY⟩ := leaf.rawDefEq
+      obtain ⟨_, hAD⟩ := uniq hXY.hasType.1 hX
+      have hXYD : IsDefEq Γ _ _ D := hAD.defeqDF hXY
+      exact alg.trans (alg.exact frame leaf hXYD) (ih hXYD.hasType.2)
+
+/-! #### Anchored native links: the chain fold without raw type uniqueness
+
+`CtorPath.foldRaw` above spends `LogRel.RawTypeUniq` once per link, and not to
+type the middle term of a `trans`: after the first link the anchor travels with
+the term.  What it reconciles is the link's *own* result type — the `A` of
+`CtorExact`'s retained `SpineWF` certificate — against the anchor inherited
+from the root.  The definitions below retain that reconciliation as a transport
+attached to the native leaf, so that the fold performs no type identification
+of its own.  See the 2026-08-15 chain-wall entry in
+`plans/l4l-16c-buildp-premortem.md`. -/
+
+/-- The retyping action a normalized chain performs at one native link:
+transport the link's typed equality to any domain that types one of its
+endpoints.
+
+This is deliberately a transport rather than a sort-level type equality.  The
+fold never needs the two types identified — only the equality moved — so
+producing `∃ u, IsDefEq Γ A D (.sort u)` and then converting at every call site
+would erase the very step a consumer replays.  Both endpoints are served so
+that a mirrored link (`CtorExact.symm`) needs no separate producer. -/
+structure LRS.CtorRetype (Γ : List SExpr) (X Y : SExpr) : Prop where
+  /-- Retype from a domain that types the left endpoint. -/
+  ofLeft : ∀ {D : SExpr}, IsDefEq Γ X X D → IsDefEq Γ X Y D
+  /-- Retype from a domain that types the right endpoint. -/
+  ofRight : ∀ {D : SExpr}, IsDefEq Γ Y Y D → IsDefEq Γ X Y D
+
+/-- The retyping of a link is unchanged by mirroring it. -/
+theorem LRS.CtorRetype.symm (H : LRS.CtorRetype Γ X Y) :
+    LRS.CtorRetype Γ Y X where
+  ofLeft h := (H.ofRight h).symm
+  ofRight h := (H.ofLeft h).symm
+
+/-- Environment-level constructor result-type discipline, path-valued: the
+result type recorded by a classified constructor's application spine *is* the
+type of that application, up to a heterogeneous conversion path.
+
+This is route (ii) of the 2026-08-15 chain-wall audit, stated exactly.  It is
+strictly weaker than `LogRel.RawTypeUniq` in two independent ways: its subject
+is a registered constructor application whose head typing and spine
+certificate are both retained, rather than an arbitrary term; and its
+conclusion is a `TypeDefEqPath` rather than a collapsed conversion, so it never
+charges `TypeDefEqPath.collapse` — which is itself the whole of raw type
+uniqueness. -/
+def LRS.CtorSpineTypeUniqPath (Γ : List SExpr) : Prop :=
+  ∀ {c : Name} {ls : List SLevel} {args : List SExpr} {CHead A D : SExpr},
+    Params.classify c = some (.ctor args.length) →
+    IsDefEq Γ (.const c ls) (.const c ls) CHead →
+    SExpr.SpineWF Γ CHead args.reverse A →
+    IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+      (args.foldr (fun a f => f.app a) (.const c ls)) D →
+    ∃ u, TypeDefEqPath Γ A D u
+
+/-- Raw type uniqueness supplies the discipline by a single-edge path.  This
+certifies that nothing has been strengthened: the new obligation is implied by
+the one it replaces. -/
+theorem LRS.CtorSpineTypeUniqPath.of_rawTypeUniq
+    (uniq : LogRel.RawTypeUniq Γ) : LRS.CtorSpineTypeUniqPath Γ := by
+  intro c ls args CHead A D _ hhead hspine hXD
+  have hXA : IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+      (args.foldr (fun a f => f.app a) (.const c ls)) A := by
+    simpa only [List.foldl_reverse] using hspine.hasType hhead
+  obtain ⟨u, hAD⟩ := uniq hXA hXD
+  exact ⟨u, .single hAD⟩
+
+/-! #### Generation-side discharge of the constructor result-type discipline
+
+Everything below discharges `LRS.CtorSpineTypeUniqPath` — and, with it, root
+subject reduction — from one named residual, without any depth index and
+without any derivation induction on the ambient equality.
+
+The pivot is an erasure repair.  `HasTypeStratifiedS.to_core` (SExpr:2580)
+*discards* the outer conversions of a stratified typing, and that discard is
+the only reason `core_aligned_of_typeUniq` has to buy the alignment back with
+`LogRel.RawTypeUniq`.  Those conversions are already `IsDefEqStrong` type
+equalities, so retaining them as a `TypeDefEqPath` costs nothing
+(`HasTypeStratifiedS.to_core_path`).  Once retained, three free steps follow:
+
+1. *Any* typing of an application spine reconstructs, one `app` node at a
+   time, as a `SExpr.SpineWF` starting from a typing of the spine's literal
+   head (`HasTypeStratifiedS.spineWF_of_foldl`).  `SpineWF` already absorbs
+   conversion paths at both ends, so no type is identified in the process.
+2. The head of a classified constructor spine is a *registered constant*, and
+   the environment assigns it exactly one declaration.  Two typings of
+   `.const c ls` therefore expose literally the same core type
+   (`LRS.constTypeUniqPath`).  This is the generation-side step, and it
+   consumes nothing at all.
+3. The two `SpineWF` runs are then compared layer by layer
+   (`SExpr.SpineWF.result_path`).
+
+Only step 3 has content, and its content is exactly Pi injectivity for type
+paths — `LRS.PiPathInv`.  Nothing here charges `TypeDefEqPath.collapse`
+(which is the whole of raw type uniqueness), nothing aligns two universe
+indices, and nothing mentions a stratification depth in its statement. -/
+
+/-- Strip the outer conversions of a stratified typing while *retaining* them
+as a heterogeneous type path.
+
+This is `HasTypeStratifiedS.to_core` (SExpr:2580) with the erasure removed.
+Every `defeq` node of a stratified derivation carries an `IsDefEqStrong` type
+equality, so the discarded conversions already form a `TypeDefEqPath`; the
+base case closes because a syntax-directed core derivation always retains a
+typing of its own type (`HasTypeStratifiedS.isType`, SExpr:2716). -/
+theorem HasTypeStratifiedS.to_core_path
+    {Γ : List SExpr} {e A : SExpr} {n : Nat}
+    (H : HasTypeStratifiedS Γ e A true n) :
+    ∃ A' u, HasTypeStratifiedS Γ e A' false n ∧ TypeDefEqPath Γ A' A u := by
+  generalize hb : true = b at H
+  induction H with cases hb
+  | base h _ =>
+    obtain ⟨u, hty⟩ := h.isType
+    exact ⟨_, u, h, .single hty.hasType⟩
+  | defeq hEq _ _ _ _ _ ih =>
+    obtain ⟨A', u, hcore, hpath⟩ := ih rfl
+    exact ⟨A', u, hcore.mono (Nat.le_succ _), hpath.trans (.single hEq.defeq)⟩
+
+/-- Align a weak self-typing with a syntax-directed core, path-valued.
+
+This is `IsDefEq.core_aligned_of_stratified_inversion` (ADQ:780) with its
+inversion package deleted: the alignment that theorem obtains from raw type
+uniqueness is the path `to_core_path` never threw away. -/
+theorem IsDefEq.core_aligned_path [Params.Semantic]
+    {Γ : List SExpr} {e A : SExpr}
+    (hΓ : Ctx.WF Γ) (H : IsDefEq Γ e e A) :
+    ∃ n A' u, HasTypeStratifiedS Γ e A' false n ∧ TypeDefEqPath Γ A' A u := by
+  obtain ⟨n, hs, _⟩ := (H.strong hΓ).stratify
+  obtain ⟨A', u, hcore, hpath⟩ := hs.to_core_path
+  exact ⟨n, A', u, hcore, hpath⟩
+
+/-- A spine absorbs an entire conversion path on its head type, one `conv`
+edge at a time.  No universe alignment between adjacent edges is needed,
+which is why the path never has to be collapsed first. -/
+theorem SpineWF.conv_path {Γ : List SExpr} {A A' B : SExpr} {u : SLevel}
+    {es : List SExpr} (P : TypeDefEqPath Γ A A' u) :
+    SExpr.SpineWF Γ A' es B → SExpr.SpineWF Γ A es B := by
+  induction P with
+  | single h => exact fun H => .conv h H
+  | trans _ _ ih₁ ih₂ => exact fun H => ih₁ (ih₂ H)
+
+/-- The `ret` dual of `SpineWF.conv_path`: a spine absorbs an entire
+conversion path on its *result* type as well.  Ported from the green probe
+`plans/probes/probeS-spinedepth.lean`. -/
+theorem SpineWF.ret_path {Γ : List SExpr} {B B' : SExpr} {u : SLevel}
+    (P : TypeDefEqPath Γ B B' u) :
+    ∀ {A : SExpr} {es : List SExpr},
+      SExpr.SpineWF Γ A es B → SExpr.SpineWF Γ A es B' := by
+  induction P with
+  | single h => exact fun H => H.ret h
+  | trans _ _ ih₁ ih₂ => exact fun H => ih₂ (ih₁ H)
+
+/-- Path-threading inversion of an empty spine.  The incoming path is carried
+through the `conv`/`ret` edges rather than being re-created, so no typing of
+the head is required. -/
+theorem SpineWF.nil_path {Γ : List SExpr} {A B : SExpr} {es : List SExpr}
+    (H : SExpr.SpineWF Γ A es B) (hes : es = []) :
+    ∀ {C : SExpr} {u : SLevel}, TypeDefEqPath Γ C A u →
+      ∃ v, TypeDefEqPath Γ C B v := by
+  induction H with
+  | nil => exact fun P => ⟨_, P⟩
+  | cons => exact absurd hes (by simp)
+  | conv hty _ ih => exact fun P => ih hes (P.trans (.single hty))
+  | ret _ hret ih =>
+    intro C u P
+    obtain ⟨v, Q⟩ := ih hes P
+    exact ⟨v, Q.trans (.single hret)⟩
+
+/-- Path-threading inversion of a nonempty spine: the incoming path is
+extended until it reaches the syntactic Pi at which the first argument is
+consumed.  The Pi is exposed *as the path's right endpoint*, which is exactly
+the form `LRS.PiPathInv` inverts. -/
+theorem SpineWF.cons_path {Γ : List SExpr} {A B : SExpr} {es : List SExpr}
+    {e : SExpr} {es' : List SExpr}
+    (H : SExpr.SpineWF Γ A es B) (hes : es = e :: es') :
+    ∀ {C : SExpr} {u : SLevel}, TypeDefEqPath Γ C A u →
+      ∃ D₁ D₂ w, TypeDefEqPath Γ C (.forallE D₁ D₂) w ∧
+        IsDefEq Γ e e D₁ ∧ SExpr.SpineWF Γ (D₂.inst e) es' B := by
+  induction H with
+  | nil => exact absurd hes (by simp)
+  | cons he rest _ =>
+    intro C u P
+    injection hes with hee hess
+    subst hee
+    subst hess
+    exact ⟨_, _, u, P, he, rest⟩
+  | conv hty _ ih => exact fun P => ih hes (P.trans (.single hty))
+  | ret _ hret ih =>
+    intro C u P
+    obtain ⟨D₁, D₂, w, Q, hD, rest⟩ := ih hes P
+    exact ⟨D₁, D₂, w, Q, hD, rest.ret hret⟩
+
+/-- Every stratified typing of a left-associated application spine *is* a
+`SExpr.SpineWF` from a typing of the spine's literal head.
+
+`HasTypeStratifiedS.foldl_app_head` (SExpr:2634) already walks the spine, but
+retains only the head; this retains the whole layer structure and the exact
+result type of the walk.  The proof consumes nothing: the recursion is on the
+argument list, each `app` node is exposed by `to_core_path`, and the discarded
+conversions are absorbed by `SpineWF.conv_path`. -/
+theorem HasTypeStratifiedS.spineWF_of_foldl_bound {Γ : List SExpr} :
+    ∀ {es : List SExpr} {hd V : SExpr} {n : Nat},
+      HasTypeStratifiedS Γ (es.foldl (fun f a => f.app a) hd) V true n →
+      ∃ HdTy m, m + es.length ≤ n ∧ HasTypeStratifiedS Γ hd HdTy true m ∧
+        SExpr.SpineWF Γ HdTy es V := by
+  intro es
+  induction es with
+  | nil => intro hd V n H; exact ⟨V, n, by simp, H, .nil⟩
+  | cons a es ih =>
+    intro hd V n H
+    simp only [List.foldl_cons] at H
+    obtain ⟨HdTy', m, hle, hHead', hspine⟩ := ih H
+    obtain ⟨T, u, hcore, hpath⟩ := hHead'.to_core_path
+    cases hcore with
+    | app hA hB hf ha hR =>
+      simp only [List.length_cons] at hle ⊢
+      exact ⟨_, _, by omega, hf,
+        .cons ha.hasType (SpineWF.conv_path hpath hspine)⟩
+
+/-- The unbounded form.  Statement unchanged; the bound follows by `omega`
+wherever a consumer wants it. -/
+theorem HasTypeStratifiedS.spineWF_of_foldl {Γ : List SExpr} :
+    ∀ {es : List SExpr} {hd V : SExpr} {n : Nat},
+      HasTypeStratifiedS Γ (es.foldl (fun f a => f.app a) hd) V true n →
+      ∃ HdTy m, HasTypeStratifiedS Γ hd HdTy true m ∧
+        SExpr.SpineWF Γ HdTy es V := by
+  intro es hd V n H
+  obtain ⟨HdTy, m, _, hhd, hspine⟩ := H.spineWF_of_foldl_bound
+  exact ⟨HdTy, m, hhd, hspine⟩
+
+/-- **The generation-side step.**  Two typings of one registered constant are
+path-equal, and the proof consumes no uniqueness, no inversion and no
+adequacy.
+
+The environment assigns `c` exactly one declaration, so the two core
+derivations expose *literally the same* type `SExpr.mkInst ls ci.type`; the
+two conversion paths retained by `to_core_path` then compose.  This is the
+sense in which the residual has left the depth-indexed fixpoint: its subject
+is a registered declaration, and a registered declaration has one type. -/
+theorem LRS.constTypeUniqPath [Params.Semantic] {Γ : List SExpr} {c : Name}
+    {ls : List SLevel} {T₁ T₂ : SExpr} {n : Nat} (hΓ : Ctx.WF Γ)
+    (h₁ : IsDefEq Γ (.const c ls) (.const c ls) T₁)
+    (h₂ : HasTypeStratifiedS Γ (.const c ls) T₂ true n) :
+    ∃ u, TypeDefEqPath Γ T₁ T₂ u := by
+  obtain ⟨_, C₁, u₁, hcore₁, hpath₁⟩ := h₁.core_aligned_path hΓ
+  obtain ⟨C₂, u₂, hcore₂, hpath₂⟩ := h₂.to_core_path
+  cases hcore₁ with
+  | const hreg₁ _ _ =>
+    cases hcore₂ with
+    | const hreg₂ _ _ =>
+      cases hreg₁.symm.trans hreg₂
+      obtain ⟨v, hpath₁'⟩ := hpath₁.symm
+      exact ⟨v, hpath₁'.trans hpath₂⟩
+
+/-- Pi injectivity for heterogeneous type paths, uniformly over well-formed
+target contexts.  This is the *single* residual of the chain wall after the
+repair.
+
+Three things are deliberately absent from the statement.  There is no
+stratification depth: unlike `JointStratifiedPathInversion.forallEInv`
+(ADQ:234) it demands no endpoint certificates, so no consumer has to name a
+depth.  There is no universe alignment: `sortPathInv` is never needed by any
+consumer below.  And there is no collapse: the conclusion is again path-valued,
+so `TypeDefEqPath.collapse` — which is the whole of raw type uniqueness — is
+never charged.  `LRS.PiPathInv.of_adequacy` in `ShapeLogRelAdequacy.lean` is
+the producer, and `LRS.PiPathInv.of_jointStratifiedPathInversion` there
+certifies that this is a weakening of the package it replaces. -/
+def LRS.PiPathInv : Prop :=
+  ∀ {Γ : List SExpr} {A B A' B' : SExpr} {s : SLevel},
+    Ctx.WF Γ → TypeDefEqPath Γ (.forallE A B) (.forallE A' B') s →
+    ∃ u v, TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+
+/-- Two spines over the *same* argument list, started from path-equal head
+types, reach path-equal result types.
+
+This is the only step with content, and its content is `LRS.PiPathInv`, spent
+once per argument.  Each layer inverts the Pi exposed by `SpineWF.cons_path`
+and substitutes the shared argument into the resulting codomain path; the
+`conv`/`ret` edges of either spine are absorbed into the running path without
+any identification. -/
+theorem SpineWF.result_path {Γ : List SExpr} {A₁ B₁ : SExpr} {es : List SExpr}
+    (piInv : LRS.PiPathInv) (hΓ : Ctx.WF Γ)
+    (H₁ : SExpr.SpineWF Γ A₁ es B₁) :
+    ∀ {A₂ B₂ : SExpr} {u : SLevel}, SExpr.SpineWF Γ A₂ es B₂ →
+      TypeDefEqPath Γ A₁ A₂ u → ∃ v, TypeDefEqPath Γ B₁ B₂ v := by
+  induction H₁ with
+  | nil => exact fun H₂ P => H₂.nil_path rfl P
+  | @cons e A₁' A₂' es₀ B₀ he _ ih =>
+    intro A₂ B₂ u H₂ P
+    obtain ⟨D₁, D₂, w, Q, _, H₂'⟩ := H₂.cons_path rfl P
+    obtain ⟨_, _, _, hcod⟩ := piInv hΓ Q
+    have hsub := hcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar he)
+    exact ih H₂' (by simpa only [SExpr.inst] using hsub)
+  | conv hty _ ih =>
+    intro A₂ B₂ u H₂ P
+    exact ih H₂ ((TypeDefEqPath.single hty.symm).trans P)
+  | ret _ hret ih =>
+    intro A₂ B₂ u H₂ P
+    obtain ⟨v, Q⟩ := ih H₂ P
+    exact ⟨_, (TypeDefEqPath.single hret.symm).trans Q⟩
+
+/-- **The environment-level statement, in full generality.**  Any two typings
+of one fully-applied *registered-constant* spine are path-equal.
+
+Note what the proof does not use: no classification of `c` is required at all.
+The result-type discipline the chain fold needs is not special to
+constructors — it is the discipline of registered declarations, and the
+constructor classification only selects which spines the fold meets. -/
+theorem LRS.constSpineTypeUniqPath [Params.Semantic] {Γ : List SExpr}
+    {c : Name} {ls : List SLevel} {args : List SExpr} {T₁ T₂ : SExpr}
+    (piInv : LRS.PiPathInv) (hΓ : Ctx.WF Γ)
+    (h₁ : IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+      (args.foldr (fun a f => f.app a) (.const c ls)) T₁)
+    (h₂ : IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+      (args.foldr (fun a f => f.app a) (.const c ls)) T₂) :
+    ∃ u, TypeDefEqPath Γ T₁ T₂ u := by
+  obtain ⟨n₁, hs₁, _⟩ := (h₁.strong hΓ).stratify
+  obtain ⟨n₂, hs₂, _⟩ := (h₂.strong hΓ).stratify
+  rw [← List.foldl_reverse] at hs₁ hs₂
+  obtain ⟨Hd₁, m₁, hhd₁, hsp₁⟩ := hs₁.spineWF_of_foldl
+  obtain ⟨Hd₂, m₂, hhd₂, hsp₂⟩ := hs₂.spineWF_of_foldl
+  obtain ⟨_, hlink⟩ := LRS.constTypeUniqPath hΓ hhd₁.hasType hhd₂
+  exact hsp₁.result_path piInv hΓ hsp₂ hlink
+
+/-- Path-valued Pi injectivity discharges the constructor result-type
+discipline outright.  This is the intended producer of
+`LRS.CtorSpineTypeUniqPath`, and the counterpart of `.of_rawTypeUniq` above:
+the same conclusion from a strictly weaker input. -/
+theorem LRS.CtorSpineTypeUniqPath.of_piPathInv [Params.Semantic]
+    {Γ : List SExpr} (piInv : LRS.PiPathInv) (hΓ : Ctx.WF Γ) :
+    LRS.CtorSpineTypeUniqPath Γ := by
+  intro c ls args CHead A D _ hhead hspine hXD
+  have hXA : IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+      (args.foldr (fun a f => f.app a) (.const c ls)) A := by
+    simpa only [List.foldl_reverse] using hspine.hasType hhead
+  exact LRS.constSpineTypeUniqPath piInv hΓ hXA hXD
+
+/-! #### Weak-head subject reduction from the same residual
+
+`WHRed.defeq_of_stratified_inversion` (ADQ:796) opens every case with
+`core_aligned_of_stratified_inversion`, i.e. with raw type uniqueness at the
+reducing term.  With the alignment retained instead of repurchased, the
+application and major cases become free, `beta` spends only `LRS.PiPathInv`,
+and the registered-contraction case spends only the spine discipline above —
+`Pattern.MatchesS.head_spine` (SExpr:899) says a matched redex *is* a
+constant-headed spine, so its two type observations are reconciled by exactly
+the environment-level fact the constructor leaves use.
+
+The multi-step form then needs no re-certification at all.  The 2026-08-15
+audit's obstruction was that `WHRedS.defeq_of_stratified_inversion` (ADQ:841)
+takes each next step's typing from `ih.hasType.2`, whose stratified depth is
+existential, so a redex certificate bounds only the first step.  That
+obstruction is dissolved rather than answered: the per-step lemma below names
+no depth, so there is nothing left for the induction to lose. -/
+
+/-- One weak-head step preserves a supplied type, from path-valued Pi
+injectivity alone. -/
+theorem WHRed.defeq_of_piPathInv [Params.Semantic] {Γ : List SExpr}
+    {e1 e2 A : SExpr}
+    (piInv : LRS.PiPathInv) (hΓ : Ctx.WF Γ)
+    (H : WHRed Γ e1 e2) (he : IsDefEq Γ e1 e1 A) :
+    IsDefEq Γ e1 e2 A := by
+  induction H generalizing A with
+  | app hred ih =>
+    obtain ⟨_, _, _, hcore, hty⟩ := he.core_aligned_path hΓ
+    cases hcore with
+    | app hD hC hf ha hR =>
+      exact hty.defeqDF (.appDF (ih hf.hasType) ha.hasType)
+  | major hmajor hred ih =>
+    obtain ⟨_, _, _, hcore, hty⟩ := he.core_aligned_path hΓ
+    cases hcore with
+    | app hD hC hf ha hR =>
+      exact hty.defeqDF (.appDF hf.hasType (ih ha.hasType))
+  | beta =>
+    obtain ⟨_, _, _, hcore, hty⟩ := he.core_aligned_path hΓ
+    cases hcore with
+    | app hD hC hlam ha hR =>
+      obtain ⟨_, _, _, hlamCore, hlamTy⟩ := hlam.hasType.core_aligned_path hΓ
+      cases hlamCore with
+      | lam hDom hCod hBody hPi =>
+        obtain ⟨_, _, hDomEq, hCodEq⟩ := piInv hΓ hlamTy
+        obtain ⟨_, hDomEq'⟩ := hDomEq.symm
+        have haDom := hDomEq'.defeqDF ha.hasType
+        have hβ := IsDefEq.beta hBody.hasType haDom
+        have hCodInst := hCodEq.subst
+          (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar haDom)
+        exact hty.defeqDF (hCodInst.defeqDF hβ)
+  | extra action =>
+    obtain ⟨_, _, _, hcore, hty⟩ := he.core_aligned_path hΓ
+    obtain ⟨c, ls', args, heq, _⟩ := action.matched.head_spine
+    subst heq
+    obtain ⟨_, hActionTy⟩ :=
+      LRS.constSpineTypeUniqPath piInv hΓ hcore.hasType action.sound.hasType.1
+    obtain ⟨_, hActionTy'⟩ := hActionTy.symm
+    exact hty.defeqDF (hActionTy'.defeqDF action.sound)
+
+/-- Multi-step weak-head subject reduction, from the same residual.  Nothing
+is re-certified along the sequence because nothing in the per-step lemma is
+indexed by a depth. -/
+theorem WHRedS.defeq_of_piPathInv [Params.Semantic] {Γ : List SExpr}
+    {e1 e2 A : SExpr}
+    (piInv : LRS.PiPathInv) (hΓ : Ctx.WF Γ)
+    (H : WHRedS Γ e1 e2) (he : IsDefEq Γ e1 e1 A) :
+    IsDefEq Γ e1 e2 A := by
+  induction H with
+  | rfl => exact he
+  | tail hred hstep ih =>
+    exact ih.trans (hstep.defeq_of_piPathInv piInv hΓ ih.hasType.2)
+
+/-- The constructor result-type discipline retypes every native exact link.
+Both directions are served by the same environment-level fact: for the right
+endpoint it is applied twice at that endpoint's own spine certificate, once
+against the link's type and once against the requested domain, and the two
+paths are composed.  No sort index is ever identified. -/
+theorem LRS.CtorExact.retype_of_ctorSpineTypeUniqPath
+    (disc : LRS.CtorSpineTypeUniqPath Γ)
+    (H : LRS.CtorExact Γ J X Y p) : LRS.CtorRetype Γ X Y := by
+  cases H with
+  | @intro c rargs hwf ls ls' args args' CHead CHead' A A'
+      hcl hlen hlen' hlevels hhead hhead' hspine hspine' hargs haligned hmirror =>
+    subst ls'
+    have hXY : IsDefEq Γ (args.foldr (fun a f => f.app a) (.const c ls))
+        (args'.foldr (fun a f => f.app a) (.const c ls)) A := by
+      simpa only [List.foldl_reverse] using haligned.spine.congr hhead
+    have hcl' : Params.classify c = some (.ctor args'.length) := by
+      simpa [hlen, hlen'] using hcl
+    refine ⟨?_, ?_⟩
+    · intro D hXD
+      obtain ⟨_, hpath⟩ := disc hcl hhead hspine hXD
+      exact hpath.defeqDF hXY
+    · intro D hYD
+      obtain ⟨_, hpathA⟩ := disc hcl' hhead' hspine' hXY.hasType.2
+      obtain ⟨_, hpathD⟩ := disc hcl' hhead' hspine' hYD
+      obtain ⟨_, hpathAr⟩ := hpathA.symm
+      exact (hpathAr.trans hpathD).defeqDF hXY
+
+/-- Every framed native leaf under one root observation admits the link
+retyping.  Scoped to the frame and the leaf rather than to the whole
+environment: this is exactly the pair `LRS.CtorPath.RawAlgebra.exact` already
+receives, so the discipline cannot be satisfied by a retyping belonging to some
+other constructor observation. -/
+def LRS.CtorAnchorDisciplineAt (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) : Prop :=
+  ∀ {k : Nat} {J : LogRel Γ k} {p : WShape (k + 1)} {X Y : SExpr},
+    LRS.CtorFrame Γ IH m J p → LRS.CtorExact Γ J X Y p →
+    LRS.CtorRetype Γ X Y
+
+theorem LRS.CtorAnchorDisciplineAt.of_ctorSpineTypeUniqPath
+    (disc : LRS.CtorSpineTypeUniqPath Γ) :
+    LRS.CtorAnchorDisciplineAt Γ IH m :=
+  fun _ leaf => leaf.retype_of_ctorSpineTypeUniqPath disc
+
+/-- The discipline is implied by the raw type uniqueness it replaces. -/
+theorem LRS.CtorAnchorDisciplineAt.of_rawTypeUniq
+    (uniq : LogRel.RawTypeUniq Γ) :
+    LRS.CtorAnchorDisciplineAt Γ IH m :=
+  LRS.CtorAnchorDisciplineAt.of_ctorSpineTypeUniqPath
+    (LRS.CtorSpineTypeUniqPath.of_rawTypeUniq uniq)
+
+/-- Fold a normalized path with no type identification at all: each link
+retypes itself at the inherited anchor, and the retyped right endpoint anchors
+the tail.  This is `CtorPath.foldRaw` with `LogRel.RawTypeUniq` replaced by the
+strictly weaker per-leaf transport. -/
+theorem LRS.CtorPath.foldRaw_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (alg : LRS.CtorPath.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorPath Γ IH m X Y)
+    (hX : IsDefEq Γ X X D) : Q X Y := by
+  induction H with
+  | single link =>
+    cases link with
+    | intro frame leaf =>
+      exact alg.exact frame leaf ((disc frame leaf).ofLeft hX)
+  | cons link rest ih =>
+    cases link with
+    | intro frame leaf =>
+      have hXYD := (disc frame leaf).ofLeft hX
+      exact alg.trans (alg.exact frame leaf hXYD) (ih hXYD.hasType.2)
+
+/-- The raw half of the path consumer, likewise free of type identification.
+This is `CtorPath.rawDefEqAt` with the per-leaf transport in place of
+`LogRel.RawTypeUniq`. -/
+theorem LRS.CtorPath.rawDefEqAt_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (H : LRS.CtorPath Γ IH m X Y)
+    (hX : IsDefEq Γ X X D) : IsDefEq Γ X Y D := by
+  induction H with
+  | single link =>
+    cases link with
+    | intro frame leaf => exact (disc frame leaf).ofLeft hX
+  | cons link rest ih =>
+    cases link with
+    | intro frame leaf =>
+      have hXYD := (disc frame leaf).ofLeft hX
+      exact hXYD.trans (ih hXYD.hasType.2)
+
+theorem LRS.CtorPath.append
+    (H₁ : LRS.CtorPath Γ IH m X Y)
+    (H₂ : LRS.CtorPath Γ IH m Y Z) :
+    LRS.CtorPath Γ IH m X Z := by
+  induction H₁ with
+  | single link => exact .cons link H₂
+  | cons link _ ih => exact .cons link (ih H₂)
+
+theorem LRS.CtorPath.symm
+    (H : LRS.CtorPath Γ IH m X Y) :
+    LRS.CtorPath Γ IH m Y X := by
+  induction H with
+  | single link => exact .single link.symm
+  | cons link _ ih => exact ih.append (.single link.symm)
+
+theorem LRS.CtorPath.mono (hle : m' ≤ m)
+    (H : LRS.CtorPath Γ IH m X Y) :
+    LRS.CtorPath Γ IH m' X Y := by
+  induction H with
+  | single link => exact .single (link.mono hle)
+  | cons link _ ih => exact .cons (link.mono hle) ih
+
+theorem LRS.CtorPath.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorPath Γ IH m X Y) :
+    LRS.CtorPath Γ IH' (m.lift (n' + 1)) X Y := by
+  induction H with
+  | single link => exact .single (link.lift le E)
+  | cons link _ ih => exact .cons (link.lift le E) ih
+
+theorem LRS.CtorPath.unlift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorPath Γ IH' (m.lift (n' + 1)) X Y) :
+    LRS.CtorPath Γ IH m X Y := by
+  induction H with
+  | single link => exact .single (link.unlift le E)
+  | cons link _ ih => exact .cons (link.unlift le E) ih
+
+/-- Root-anchored constructor normal form.  The endpoint views isolate all
+weak-head bookkeeping; the path between their classified spines consists
+only of exact native links. -/
+inductive LRS.CtorChain (Γ : List SExpr) (IH : LogRel Γ n)
+    (M N : SExpr) (m : WShape (n + 1)) : Prop where
+  | intro {X Y : SExpr} :
+      LRS.CtorView Γ M X → LRS.CtorView Γ N Y →
+      LRS.CtorPath Γ IH m X Y → CtorChain Γ IH M N m
+
+theorem LRS.CtorChain.toCtorDefEq
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorDefEq Γ IH M N m := by
+  cases H with
+  | intro left right links =>
+    cases left with
+    | intro _ hM =>
+    cases right with
+      | intro _ hN => exact .unwhr hM hN links.toCtorDefEq
+
+/-- Compose the raw equality of a normalized chain once its two weak-head
+views have been certified at a common root type.  The callbacks are the
+precise subject-reduction boundary: chain normalization and native-link
+composition themselves do not inspect weak-head reductions. -/
+theorem LRS.CtorChain.rawDefEqAt
+    (uniq : LogRel.RawTypeUniq Γ)
+    (H : LRS.CtorChain Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) :
+    IsDefEq Γ M N D := by
+  cases H with
+  | intro hleft hright path =>
+    have hMX := left hleft
+    have hNY := right hright
+    exact hMX.trans (path.rawDefEqAt uniq hMX.hasType.2) |>.trans hNY.symm
+
+/-- A normalized-chain consumer whose native leaves and root views have all
+been retyped at one externally chosen domain.  This is the complete raw
+boundary used by the joint adequacy/uniqueness proof: `foldRaw` spends raw
+type uniqueness internally on path vertices, while the caller supplies
+subject reduction only for the two weak-head root views. -/
+structure LRS.CtorChain.RawAlgebra (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) (D : SExpr) (Q : SExpr → SExpr → Prop) where
+  exact : ∀ {k : Nat} {J : LogRel Γ k} {p : WShape (k + 1)} {X Y : SExpr},
+    LRS.CtorFrame Γ IH m J p → LRS.CtorExact Γ J X Y p →
+    IsDefEq Γ X Y D → Q X Y
+  trans : ∀ {X Y Z : SExpr}, Q X Y → Q Y Z → Q X Z
+  anchor : ∀ {M N X Y : SExpr},
+    LRS.CtorView Γ M X → LRS.CtorView Γ N Y →
+    IsDefEq Γ M X D → IsDefEq Γ N Y D → Q X Y → Q M N
+
+/-- Consume a root-anchored chain at one common raw domain.  No weak-head
+subject-reduction theorem is hidden in this fold: its only two uses are the
+explicit root callbacks. -/
+theorem LRS.CtorChain.foldRaw
+    (uniq : LogRel.RawTypeUniq Γ)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorChain Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) : Q M N := by
+  cases H with
+  | intro hleft hright path =>
+    have hMX := left hleft
+    have hNY := right hright
+    let pathAlg : LRS.CtorPath.RawAlgebra Γ IH m D Q := {
+      exact := alg.exact
+      trans := alg.trans }
+    exact alg.anchor hleft hright hMX hNY
+      (path.foldRaw uniq pathAlg hMX.hasType.2)
+
+/-- Consume a root-anchored chain with no raw type uniqueness anywhere.  The
+only remaining raw inputs are the two root callbacks, i.e. weak-head subject
+reduction *to a classified constructor spine* at the two endpoints — the one
+half of the old residual that a redex's own stratified certificate bounds. -/
+theorem LRS.CtorChain.foldRaw_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorChain Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) : Q M N := by
+  cases H with
+  | intro hleft hright path =>
+    have hMX := left hleft
+    have hNY := right hright
+    let pathAlg : LRS.CtorPath.RawAlgebra Γ IH m D Q := {
+      exact := alg.exact
+      trans := alg.trans }
+    exact alg.anchor hleft hright hMX hNY
+      (path.foldRaw_of_anchorDiscipline disc pathAlg hMX.hasType.2)
+
+/-- Extract the raw equality of a normalized chain with no type
+identification; the two root callbacks remain the only raw inputs. -/
+theorem LRS.CtorChain.rawDefEqAt_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (H : LRS.CtorChain Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) :
+    IsDefEq Γ M N D := by
+  cases H with
+  | intro hleft hright path =>
+    have hMX := left hleft
+    have hNY := right hright
+    exact hMX.trans
+      (path.rawDefEqAt_of_anchorDiscipline disc hMX.hasType.2) |>.trans hNY.symm
+
+theorem LRS.CtorChain.symm
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorChain Γ IH N M m := by
+  cases H with
+  | intro left right links => exact .intro right left links.symm
+
+/-- Retain a constructor witness while making both root endpoints the left
+endpoint.  A path followed by its mirror stays nonempty and therefore keeps
+the observation evidence needed by later consumers. -/
+theorem LRS.CtorChain.left
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorChain Γ IH M M m := by
+  cases H with
+  | intro left _ links => exact .intro left left (links.append links.symm)
+
+/-- Concatenate two root-anchored chains.  Weak-head determinism identifies
+the two classified constructor spines chosen for their shared root term. -/
+theorem LRS.CtorChain.trans
+    (H₁ : LRS.CtorChain Γ IH M N m)
+    (H₂ : LRS.CtorChain Γ IH N P m) :
+    LRS.CtorChain Γ IH M P m := by
+  cases H₁ with
+  | intro left middle₁ links₁ =>
+    cases H₂ with
+    | intro middle₂ right links₂ =>
+      cases middle₁ with
+      | intro hcl₁ hred₁ =>
+        cases middle₂ with
+        | intro hcl₂ hred₂ =>
+          have hmid := WHRedS.ctorSpine_determ hcl₁ hcl₂ hred₁ hred₂
+          exact .intro left right (links₁.append (hmid.symm ▸ links₂))
+
+theorem LRS.CtorChain.mono (hle : m' ≤ m)
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorChain Γ IH M N m' := by
+  cases H with
+  | intro left right links => exact .intro left right (links.mono hle)
+
+theorem LRS.CtorChain.whr
+    (hM : WHRedS Γ M M') (hN : WHRedS Γ N N')
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorChain Γ IH M' N' m := by
+  cases H with
+  | intro left right links =>
+    exact .intro (left.whr hM) (right.whr hN) links
+
+theorem LRS.CtorChain.unwhr
+    (hM : WHRedS Γ M M') (hN : WHRedS Γ N N')
+    (H : LRS.CtorChain Γ IH M' N' m) :
+    LRS.CtorChain Γ IH M N m := by
+  cases H with
+  | intro left right links =>
+    exact .intro (left.unwhr hM) (right.unwhr hN) links
+
+theorem LRS.CtorChain.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorChain Γ IH' M N (m.lift (n' + 1)) := by
+  cases H with
+  | intro left right links => exact .intro left right (links.lift le E)
+
+theorem LRS.CtorChain.unlift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LRS.CtorChain Γ IH' M N (m.lift (n' + 1))) :
+    LRS.CtorChain Γ IH M N m := by
+  cases H with
+  | intro left right links => exact .intro left right (links.unlift le E)
+
+/-- The elimination interface exposed by normalized constructor chains.
+A consumer handles native exact leaves (with their full transport frame),
+ordinary composition, and the two root views.  In particular it never sees
+the original `left`/`symm`/`mono`/`lift`/`unlift` free closure. -/
+structure LRS.CtorChain.Algebra (Γ : List SExpr) (IH : LogRel Γ n)
+    (m : WShape (n + 1)) (Q : SExpr → SExpr → Prop) where
+  exact : ∀ {k : Nat} {J : LogRel Γ k} {p : WShape (k + 1)} {X Y : SExpr},
+    LRS.CtorFrame Γ IH m J p → LRS.CtorExact Γ J X Y p → Q X Y
+  trans : ∀ {X Y Z : SExpr}, Q X Y → Q Y Z → Q X Z
+  anchor : ∀ {M N X Y : SExpr},
+    LRS.CtorView Γ M X → LRS.CtorView Γ N Y → Q X Y → Q M N
+
+/-- Fold a nonempty exact-link path through the normalized consumer
+interface. -/
+theorem LRS.CtorPath.fold
+    (alg : LRS.CtorChain.Algebra Γ IH m Q)
+    (H : LRS.CtorPath Γ IH m X Y) : Q X Y := by
+  induction H with
+  | single link =>
+    cases link with
+    | intro frame exact => exact alg.exact frame exact
+  | cons link _ ih =>
+    cases link with
+    | intro frame exact => exact alg.trans (alg.exact frame exact) ih
+
+/-- Consume a root-anchored chain.  This is the intended entry point for the
+limited-uniqueness-aware iota leaf: all transport choices remain local to
+the exact link that introduced them. -/
+theorem LRS.CtorChain.fold
+    (alg : LRS.CtorChain.Algebra Γ IH m Q)
+    (H : LRS.CtorChain Γ IH M N m) : Q M N := by
+  cases H with
+  | intro left right links => exact alg.anchor left right (links.fold alg)
+
+/-- The original free constructor relation is one consumer of the normalized
+interface.  This instance is also a sanity check that the algebra loses no
+transport or endpoint evidence. -/
+theorem LRS.CtorChain.defEqAlgebra :
+    LRS.CtorChain.Algebra Γ IH m
+      (fun X Y => LRS.CtorDefEq Γ IH X Y m) where
+  exact frame leaf := frame.apply leaf.toCtorDefEq
+  trans H₁ H₂ := H₁.trans H₂
+  anchor left right H := by
+    cases left with
+    | intro _ hM =>
+      cases right with
+      | intro _ hN => exact .unwhr hM hN H
+
+theorem LRS.CtorChain.fold_toCtorDefEq
+    (H : LRS.CtorChain Γ IH M N m) :
+    LRS.CtorDefEq Γ IH M N m :=
+  H.fold LRS.CtorChain.defEqAlgebra
+
+/-- Transport operations for an indexed result produced at a native exact
+leaf.  Folding a `CtorFrame` applies these operations only after that leaf
+has been completely consumed; no native field is projected through an
+`unlift`. -/
+structure LRS.CtorFrame.Algebra (Γ : List SExpr)
+    (Q : {n : Nat} → LogRel Γ n → WShape (n + 1) →
+      SExpr → SExpr → Prop) where
+  mono : ∀ {n : Nat} {IH : LogRel Γ n} {m m' : WShape (n + 1)}
+      {X Y : SExpr},
+    m ≤ m' → Q IH m' X Y → Q IH m X Y
+  lift : ∀ {n n' : Nat} {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+      {m : WShape (n + 1)} {X Y : SExpr},
+    (le : n ≤ n') → LogRel.LiftEquiv IH IH' le →
+    Q IH m X Y → Q IH' (m.lift (n' + 1)) X Y
+  unlift : ∀ {n n' : Nat} {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+      {m : WShape (n + 1)} {X Y : SExpr},
+    (le : n ≤ n') → LogRel.LiftEquiv IH IH' le →
+    Q IH' (m.lift (n' + 1)) X Y → Q IH m X Y
+
+/-- Consume a transport frame around an already completed native result. -/
+theorem LRS.CtorFrame.fold
+    (alg : LRS.CtorFrame.Algebra Γ Q)
+    (F : LRS.CtorFrame Γ IH m J p)
+    (H : Q J p X Y) : Q IH m X Y := by
+  induction F with
+  | refl => exact H
+  | mono hle _ ih => exact alg.mono hle (ih H)
+  | lift le E _ ih => exact alg.lift le E (ih H)
+  | unlift le E _ ih => exact alg.unlift le E (ih H)
+
+/-- A normalized-chain consumer split at the well-founded boundary: `exact`
+works at the leaf's native level, `frame` returns its completed result to the
+root, and `trans` composes only root-level results.  This is the interface on
+which adequacy at level `n + 1` consumes limited uniqueness at level `n`. -/
+structure LRS.CtorChain.NativeAlgebra (Γ : List SExpr)
+    (Q : {n : Nat} → LogRel Γ n → WShape (n + 1) →
+      SExpr → SExpr → Prop) where
+  frame : LRS.CtorFrame.Algebra Γ Q
+  exact : ∀ {n : Nat} {IH : LogRel Γ n} {m : WShape (n + 1)}
+      {X Y : SExpr},
+    LRS.CtorExact Γ IH X Y m → Q IH m X Y
+  trans : ∀ {n : Nat} {IH : LogRel Γ n} {m : WShape (n + 1)}
+      {X Y Z : SExpr},
+    Q IH m X Y → Q IH m Y Z → Q IH m X Z
+  anchor : ∀ {n : Nat} {IH : LogRel Γ n} {m : WShape (n + 1)}
+      {M N X Y : SExpr},
+    LRS.CtorView Γ M X → LRS.CtorView Γ N Y →
+    Q IH m X Y → Q IH m M N
+
+/-- Specialize an indexed native consumer to one root relation and shape. -/
+theorem LRS.CtorChain.NativeAlgebra.atRoot
+    (alg : LRS.CtorChain.NativeAlgebra Γ Q) :
+    LRS.CtorChain.Algebra Γ IH m (Q IH m) where
+  exact frame leaf := frame.fold alg.frame (alg.exact leaf)
+  trans H₁ H₂ := alg.trans H₁ H₂
+  anchor left right H := alg.anchor left right H
+
+/-- Fold a normalized chain with native completion preceding root
+composition. -/
+theorem LRS.CtorChain.foldNative
+    (alg : LRS.CtorChain.NativeAlgebra Γ Q)
+    (H : LRS.CtorChain Γ IH M N m) : Q IH m M N :=
+  H.fold alg.atRoot
+
+/-- Normalize the free constructor-observation closure into a root-anchored
+chain of native exact leaves. -/
+theorem LRS.CtorDefEq.toChain
+    (H : LRS.CtorDefEq Γ IH M N m) :
+    LRS.CtorChain Γ IH M N m := by
+  induction H with
+  | exact hcl hlen hlen' hlevels hM hN hhead hhead' hspine hspine' hargs haligned
+      hmirror =>
+    exact .intro (.intro hcl hM)
+      (.intro (by simpa [hlen, hlen'] using hcl) hN) <|
+      .single <| .intro .refl <|
+        .intro hcl hlen hlen' hlevels hhead hhead' hspine hspine'
+          hargs haligned hmirror
+  | left _ ih => exact ih.left
+  | symm _ ih => exact ih.symm
+  | trans _ _ ih₁ ih₂ => exact ih₁.trans ih₂
+  | mono hle _ ih => exact ih.mono hle
+  | whr hM hN _ ih => exact ih.whr hM hN
+  | unwhr hM hN _ ih => exact ih.unwhr hM hN
+  | lift le hliftTy hlift _ ih =>
+    exact ih.lift le (.ofFields le hliftTy hlift)
+  | unlift le hliftTy hlift _ ih =>
+    exact ih.unlift le (.ofFields le hliftTy hlift)
+
+/-- Extract a raw equality from the original free constructor-observation
+closure through its normalized chain.  The caller-visible assumptions are
+exactly those of `CtorChain.rawDefEqAt`; in particular no subject reduction
+is smuggled into normalization. -/
+theorem LRS.CtorDefEq.rawDefEqAt
+    (uniq : LogRel.RawTypeUniq Γ)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) :
+    IsDefEq Γ M N D :=
+  H.toChain.rawDefEqAt uniq left right
+
+/-- Consume the original free constructor relation through the raw-aware
+normalized interface.  This is the intended adequacy entry point: callers
+handle one framed native leaf, composition, and the two explicitly typed
+root views rather than the nine constructors of `CtorDefEq`. -/
+theorem LRS.CtorDefEq.foldRaw
+    (uniq : LogRel.RawTypeUniq Γ)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) : Q M N :=
+  H.toChain.foldRaw uniq alg left right
+
+/-- Consume the original free constructor relation with the per-leaf retyping
+in place of raw type uniqueness.  Same conclusion and same root callbacks as
+`CtorDefEq.foldRaw`; the interior of the chain now identifies no types. -/
+theorem LRS.CtorDefEq.foldRaw_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) : Q M N :=
+  H.toChain.foldRaw_of_anchorDiscipline disc alg left right
+
+/-- Extract the raw equality of the original free constructor relation with no
+type identification; caller-visible assumptions are the two root callbacks
+alone. -/
+theorem LRS.CtorDefEq.rawDefEqAt_of_anchorDiscipline
+    (disc : LRS.CtorAnchorDisciplineAt Γ IH m)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (left : ∀ {X}, LRS.CtorView Γ M X → IsDefEq Γ M X D)
+    (right : ∀ {Y}, LRS.CtorView Γ N Y → IsDefEq Γ N Y D) :
+    IsDefEq Γ M N D :=
+  H.toChain.rawDefEqAt_of_anchorDiscipline disc left right
+
+/-- An algebra for consuming the free closure carried by `CtorDefEq`.
+
+The transport operations consume an already folded result.  In particular,
+`unlift` cannot inspect or project individual high-level constructor fields;
+an algebra that returns a logical-relation continuation must first evaluate
+that continuation at the higher level and then lower the completed result.
+This is the sound elimination boundary needed by proof-carrying iota
+materialization. -/
+structure LRS.CtorDefEq.Algebra (Γ : List SExpr)
+    (Q : {n : Nat} → LogRel Γ n → SExpr → SExpr → WShape (n + 1) → Prop) where
+  exact : ∀ {n : Nat} {IH : LogRel Γ n} {c : Name}
+      {rargs : List (WShape n)} {hwf} {M N : SExpr}
+      {ls ls' : List SLevel} {args args' : List SExpr}
+      {CHead CHead' A A' : SExpr},
+      Params.classify c = some (.ctor args.length) →
+      args.length = rargs.length → args'.length = rargs.length →
+      ls = ls' →
+      WHRedS Γ M (args.foldr (fun a f => f.app a) (.const c ls)) →
+      WHRedS Γ N (args'.foldr (fun a f => f.app a) (.const c ls')) →
+      IsDefEq Γ (.const c ls) (.const c ls) CHead →
+      IsDefEq Γ (.const c ls') (.const c ls') CHead' →
+      SExpr.SpineWF Γ CHead args.reverse A →
+      SExpr.SpineWF Γ CHead' args'.reverse A' →
+      LRS.CtorArgsDefEq IH args args' rargs →
+      LRS.CtorSpineDefEq IH CHead args args' rargs A →
+      LRS.CtorSpineDefEq IH CHead' args' args rargs A' →
+      Q IH M N (.ctor c rargs.reverse hwf)
+  left : ∀ {n : Nat} {IH : LogRel Γ n} {M N : SExpr} {m : WShape (n + 1)},
+      Q IH M N m → Q IH M M m
+  symm : ∀ {n : Nat} {IH : LogRel Γ n} {M N : SExpr} {m : WShape (n + 1)},
+      Q IH M N m → Q IH N M m
+  trans : ∀ {n : Nat} {IH : LogRel Γ n} {M N P : SExpr} {m : WShape (n + 1)},
+      Q IH M N m → Q IH N P m → Q IH M P m
+  mono : ∀ {n : Nat} {IH : LogRel Γ n} {M N : SExpr}
+      {m m' : WShape (n + 1)},
+      m ≤ m' → Q IH M N m' → Q IH M N m
+  whr : ∀ {n : Nat} {IH : LogRel Γ n} {M M' N N' : SExpr}
+      {m : WShape (n + 1)},
+      WHRedS Γ M M' → WHRedS Γ N N' → Q IH M N m → Q IH M' N' m
+  unwhr : ∀ {n : Nat} {IH : LogRel Γ n} {M M' N N' : SExpr}
+      {m : WShape (n + 1)},
+      WHRedS Γ M M' → WHRedS Γ N N' → Q IH M' N' m → Q IH M N m
+  lift : ∀ {n n' : Nat} {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+      {M N : SExpr} {m : WShape (n + 1)},
+      (le : n ≤ n') →
+      (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+        (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a)) →
+      (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+        (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) →
+      Q IH M N m → Q IH' M N (m.lift (n' + 1))
+  unlift : ∀ {n n' : Nat} {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+      {M N : SExpr} {m : WShape (n + 1)},
+      (le : n ≤ n') →
+      (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+        (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a)) →
+      (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+        (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) →
+      Q IH' M N (m.lift (n' + 1)) → Q IH M N m
+
+/-- Fold a constructor observation through a transport-aware algebra. -/
+theorem LRS.CtorDefEq.fold
+    (alg : LRS.CtorDefEq.Algebra Γ Q)
+    (H : LRS.CtorDefEq Γ IH M N m) : Q IH M N m := by
+  induction H with
+  | exact hcl hlen hlen' hlevels hM hN hhead hhead' hspine hspine' hargs haligned
+      haligned' =>
+    exact alg.exact hcl hlen hlen' hlevels hM hN hhead hhead' hspine hspine'
+      hargs haligned haligned'
+  | left _ ih => exact alg.left ih
+  | symm _ ih => exact alg.symm ih
+  | trans _ _ ih ih' => exact alg.trans ih ih'
+  | mono hle _ ih => exact alg.mono hle ih
+  | whr hM hN _ ih => exact alg.whr hM hN ih
+  | unwhr hM hN _ ih => exact alg.unwhr hM hN ih
+  | lift le hliftTy hlift _ ih => exact alg.lift le hliftTy hlift ih
+  | unlift le hliftTy hlift _ ih => exact alg.unlift le hliftTy hlift ih
+
+/-- Every transport-aware free-closure algebra induces a normalized native
+consumer.  Structural `left`/`symm`/`whr` cases have already become exact
+path operations and root views, so only exact completion, root composition,
+root expansion, and the three frame operations remain. -/
+theorem LRS.CtorDefEq.Algebra.toNative
+    (alg : LRS.CtorDefEq.Algebra Γ Q) :
+    LRS.CtorChain.NativeAlgebra Γ
+      (fun IH m M N => Q IH M N m) where
+  frame := {
+    mono := fun hle H => alg.mono hle H
+    lift := fun le E H => alg.lift le E.ty E.term H
+    unlift := fun le E H => alg.unlift le E.ty E.term H }
+  exact leaf := by
+    cases leaf with
+    | intro hcl hlen hlen' hlevels hhead hhead' hspine hspine' hargs haligned hmirror =>
+      exact alg.exact hcl hlen hlen' hlevels .rfl .rfl hhead hhead' hspine hspine'
+        hargs haligned hmirror
+  trans H₁ H₂ := alg.trans H₁ H₂
+  anchor left right H := by
+    cases left with
+    | intro _ hM =>
+      cases right with
+      | intro _ hN => exact alg.unwhr hM hN H
+
+/-- The normalized route can consume every original constructor observation
+through any existing algebra. -/
+theorem LRS.CtorDefEq.foldChain
+    (alg : LRS.CtorDefEq.Algebra Γ Q)
+    (H : LRS.CtorDefEq Γ IH M N m) : Q IH M N m :=
+  H.toChain.foldNative alg.toNative
+
+def LRS.IndDefEq (Γ : List SExpr) (IH : LogRel Γ n)
+    (M N A : SExpr) (m : WShape (n+1)) : Prop :=
+  match m.1 with
+  | .bot => True
+  | _ => LRS.IndTyHead Γ A ∧ LRS.CtorDefEq Γ IH M N m
+
+theorem LRS.IndDefEq.left :
+    LRS.IndDefEq Γ IH M N A m → LRS.IndDefEq Γ IH M M A m := by
+  dsimp [LRS.IndDefEq]; split <;> try trivial
+  exact fun h => ⟨h.1, .left h.2⟩
+
+theorem LRS.IndDefEq.symm :
+    LRS.IndDefEq Γ IH M N A m → LRS.IndDefEq Γ IH N M A m := by
+  dsimp [LRS.IndDefEq]; split <;> try trivial
+  exact fun h => ⟨h.1, .symm h.2⟩
+
+theorem LRS.IndDefEq.trans :
+    LRS.IndDefEq Γ IH M₁ M₂ A m → LRS.IndDefEq Γ IH M₂ M₃ A m →
+      LRS.IndDefEq Γ IH M₁ M₃ A m := by
+  dsimp [LRS.IndDefEq]; split <;> try trivial
+  exact fun h₁ h₂ => ⟨h₁.1, .trans h₁.2 h₂.2⟩
+
+theorem LRS.IndDefEq.mono_l (le : m ≤ m') (hm : m.HasType WShape.indTy) :
+    LRS.IndDefEq Γ IH M N A m' → LRS.IndDefEq Γ IH M N A m := by
+  cases m using WShape.casesOn' with
+  | bot => intro; trivial
+  | ctor c l h =>
+    have le' := le
+    rw [WShape.ctor_le] at le'
+    obtain ⟨l', h', rfl, _⟩ := le'
+    intro hE
+    exact ⟨hE.1, .mono le hE.2⟩
+  | _ => cases hm
+
+theorem LRS.IndDefEq.whr (hM : WHRedS Γ M M') (hN : WHRedS Γ N N') :
+    LRS.IndDefEq Γ IH M N A m ↔ LRS.IndDefEq Γ IH M' N' A m := by
+  dsimp [LRS.IndDefEq]; split
+  · rfl
+  · exact and_congr Iff.rfl (LRS.CtorDefEq.whr_iff hM hN)
+
+theorem LRS.IndDefEq.lift {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+    {m : WShape (n+1)} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+    LRS.IndDefEq Γ IH' M N A (m.lift (n'+1)) ↔
+      LRS.IndDefEq Γ IH M N A m := by
+  cases m using WShape.casesOn' with
+  | bot => rw [WShape.lift_bot]; exact Iff.rfl
+  | sort r =>
+    change (LRS.IndTyHead Γ A ∧ LRS.CtorDefEq Γ IH' M N
+      ((WShape.sort r : WShape (n+1)).lift (n'+1))) ↔
+      (LRS.IndTyHead Γ A ∧ LRS.CtorDefEq Γ IH M N (WShape.sort r))
+    exact and_congr Iff.rfl (LRS.CtorDefEq.lift_iff le hliftTy hlift)
+  | forallE b f =>
+    have hc := LRS.CtorDefEq.lift_iff
+      (M := M) (N := N) (m := WShape.forallE b f) le hliftTy hlift
+    rw [WShape.lift_forallE le] at hc ⊢
+    simpa only [LRS.IndDefEq, WShape.forallE] using
+      (and_congr Iff.rfl hc)
+  | lam f h =>
+    have hc := LRS.CtorDefEq.lift_iff
+      (M := M) (N := N) (m := WShape.lam f h) le hliftTy hlift
+    rw [WShape.lift_lam le] at hc ⊢
+    simpa only [LRS.IndDefEq, WShape.lam] using
+      (and_congr Iff.rfl hc)
+  | ctor c l h =>
+    have hc := LRS.CtorDefEq.lift_iff
+      (M := M) (N := N) (m := WShape.ctor c l h) le hliftTy hlift
+    rw [WShape.lift_ctor le] at hc ⊢
+    simpa only [LRS.IndDefEq, WShape.ctor] using
+      (and_congr Iff.rfl hc)
+  | indTy =>
+    change (LRS.IndTyHead Γ A ∧ LRS.CtorDefEq Γ IH' M N
+      ((WShape.indTy : WShape (n+1)).lift (n'+1))) ↔
+      (LRS.IndTyHead Γ A ∧ LRS.CtorDefEq Γ IH M N WShape.indTy)
+    exact and_congr Iff.rfl (LRS.CtorDefEq.lift_iff le hliftTy hlift)
+
 /-- Type validity at element-shape `m` (merged `TyDefEq` / `EqTyDefEq`).
 Non-trivial at `.forallE` (Pi injectivity) and `.sort` (sort injectivity). -/
 def LRS.TyDefEq (IH : LogRel Γ n) (M N : SExpr) : WShape (n+1) → Prop
-  | ⟨.bot, _⟩ | ⟨.lam _, _⟩ | ⟨.ctor _ _, _⟩ | ⟨.indTy, _⟩ => True
+  | ⟨.bot, _⟩ | ⟨.lam _, _⟩ | ⟨.ctor _ _, _⟩ => True
   | ⟨.sort _, _⟩ => ∃ u, Γ ⊢ M ⤳* .sort u ∧ Γ ⊢ N ⤳* .sort u
   | ⟨.forallE b f, wf⟩ => LRS.ValTyPi2 IH M N ⟨b, wf.1⟩ ⟨f, wf.2⟩
+  | ⟨.indTy, _⟩ => LRS.IndTyHead Γ M ∧ LRS.IndTyHead Γ N
 
 @[simp] theorem LRS.TyDefEq.bot : LRS.TyDefEq IH M N .bot := trivial
 @[simp] theorem LRS.TyDefEq.sort_iff :
@@ -5438,7 +12254,9 @@ theorem LRS.TyDefEq.left {IH : LogRel Γ n} :
   dsimp [LRS.TyDefEq]; split <;> try trivial
   · intro ⟨u, hM, _⟩; exact ⟨u, hM, hM⟩
   · intro ⟨B₁, F₁, _, _, u, v, rM, _, hB, hF, hValB, hE⟩
-    exact ⟨B₁, F₁, B₁, F₁, u, v, rM, rM, hB.hasType.1, hF.hasType.1, IH.left_ty hValB, hE.left⟩
+    exact ⟨B₁, F₁, B₁, F₁, u, v, rM, rM, hB.left, hF.left,
+      IH.left_ty hValB, hE.left⟩
+  · intro h; exact ⟨h.1, h.1⟩
 
 theorem LRS.TyDefEq.symm {IH : LogRel Γ n} :
     LRS.TyDefEq IH M N m → LRS.TyDefEq IH N M m := by
@@ -5446,10 +12264,15 @@ theorem LRS.TyDefEq.symm {IH : LogRel Γ n} :
   · intro ⟨u, hM, hN⟩; exact ⟨u, hN, hM⟩
   · intro ⟨_, _, _, _, _, _, rM, rN, hB, hF, hValB, hE1, hE2⟩
     have hValB' := IH.symm_ty hValB
-    refine ⟨_, _, _, _, _, _, rN, rM, hB.symm, hB.defeqDF_l hF.symm,
+    obtain ⟨u', hB'⟩ := hB.symm
+    obtain ⟨v', hF'⟩ := hF.symm
+    have hF'' := hB.defeqDF_l_path hF'
+    refine ⟨_, _, _, _, u', v', rN, rM, hB', hF'',
       hValB', fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩
-    · exact (hE1 hp (hB.symm.defeqDF ha) (IH.conv hValB' a1)).symm
-    · exact IH.symm_ty (hE2 hp (hB.symm.defeqDF ha) (IH.conv hValB' a1))
+    · let h := hE1 hp (hB'.defeqDF ha) (IH.conv hValB' a1)
+      exact ⟨h.rightTy, h.leftTy, h.rightDefEq, h.leftDefEq⟩
+    · exact IH.symm_ty (hE2 hp (hB'.defeqDF ha) (IH.conv hValB' a1))
+  · exact And.symm
 
 theorem LRS.TyDefEq.trans {IH : LogRel Γ n} :
     LRS.TyDefEq IH M₁ M₂ m → LRS.TyDefEq IH M₂ M₃ m → LRS.TyDefEq IH M₁ M₃ m := by
@@ -5459,11 +12282,16 @@ theorem LRS.TyDefEq.trans {IH : LogRel Γ n} :
   · intro ⟨B₁, F₁, B₂, F₂, u, v, rM₁, rM₂, hB₁₂, hF₁₂, hValB₁₂, hE1⟩
           ⟨_, _, B₃, F₃, u', v', rM₂', rM₃, hB₂₃, hF₂₃, hValB₂₃, hE2⟩
     cases rM₂.determ .forallE rM₂' .forallE
-    have hF₂₃' := hB₁₂.symm.defeqDF_l hF₂₃
-    refine ⟨_, _, _, _, _, _, rM₁, rM₃, hB₁₂.trans' hB₂₃, hF₁₂.trans' hF₂₃',
+    obtain ⟨_, hB₂₁⟩ := hB₁₂.symm
+    have hF₂₃' := hB₂₁.defeqDF_l_path hF₂₃
+    refine ⟨_, _, _, _, _, _, rM₁, rM₃,
+      TypeDefEqPath.trans hB₁₂ hB₂₃, TypeDefEqPath.trans hF₁₂ hF₂₃',
       IH.trans_ty hValB₁₂ hValB₂₃, fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩
-    · exact ⟨(hE1.1 hp ha a1).1, (hE2.1 hp (hB₁₂.defeqDF ha) (IH.conv hValB₁₂ a1)).2⟩
+    · let h₁ := hE1.1 hp ha a1
+      let h₂ := hE2.1 hp (hB₁₂.defeqDF ha) (IH.conv hValB₁₂ a1)
+      exact ⟨h₁.leftTy, h₂.rightTy, h₁.leftDefEq, h₂.rightDefEq⟩
     · exact IH.trans_ty (hE1.2 hp ha a1) (hE2.2 hp (hB₁₂.defeqDF ha) (IH.conv hValB₁₂ a1))
+  · exact fun h₁ h₂ => ⟨h₁.1, h₂.2⟩
 
 theorem LRS.LamDefEq.left {IH : LogRel Γ n} :
     LRS.LamDefEq IH M N B F m m₁ m₂ → LRS.LamDefEq IH M M B F m m₁ m₂ := by
@@ -5497,9 +12325,10 @@ theorem LRS.PiDefEq.mono_r_2 {IH : LogRel Γ n}
       have hp' := WShape.HasType.mono_r le₁ (WShape.HasDom.isType htpi'.1) hp
       have a2 := IH.mono_r_1 le₁ hp hp' hValA₁ a1
       have hm_tgt := (htpi_w.2 _ hp).toType; have hm_src := (htpi'_w.2 _ hp').toType
-    · let ⟨t1, t2⟩ := h1 hp' ha a2
-      exact ⟨IH.mono_r_2_ty (WShapeFun.app_mono_l le₂ x) hm_tgt hm_src t1,
-             IH.mono_r_2_ty (WShapeFun.app_mono_l le₂ x) hm_tgt hm_src t2⟩
+    · let h := h1 hp' ha a2
+      exact ⟨IH.mono_r_2_ty (WShapeFun.app_mono_l le₂ x) hm_tgt hm_src h.leftTy,
+        IH.mono_r_2_ty (WShapeFun.app_mono_l le₂ x) hm_tgt hm_src h.rightTy,
+        h.leftDefEq, h.rightDefEq⟩
     · exact IH.mono_r_2_ty (WShapeFun.app_mono_l le₂ x) hm_tgt hm_src (h2 hp' ha a2)
 
 theorem LRS.LamDefEq.mono_r_2 {IH : LogRel Γ n}
@@ -5577,11 +12406,14 @@ theorem LRS.PiDefEq.join {IH : LogRel Γ n}
       IH.mono_r_2_ty d_app ht_f1 (ht₁_w.2 d_x d_ht).toType h
     have cvt_e {A B} (h : IH.TyDefEq A B (f₂.app e_x)) : IH.TyDefEq A B (f₂.app p) :=
       IH.mono_r_2_ty e_app ht_f2 (ht₂_w.2 e_x e_ht).toType h
-  · constructor
-    · exact IH.mono_r_2_ty hC_fJ ht_fJ ht_fJ' <| IH.join_ty hC_fp ht_f1 ht_f2
-        (cvt_d (hE₁.1 d_ht ha c2).1) (cvt_e (hE₂.1 e_ht ha c3).1)
-    · exact IH.mono_r_2_ty hC_fJ ht_fJ ht_fJ' <| IH.join_ty hC_fp ht_f1 ht_f2
-        (cvt_d (hE₁.1 d_ht ha c2).2) (cvt_e (hE₂.1 e_ht ha c3).2)
+  · let hd := hE₁.1 d_ht ha c2
+    let he := hE₂.1 e_ht ha c3
+    exact ⟨
+      IH.mono_r_2_ty hC_fJ ht_fJ ht_fJ' <| IH.join_ty hC_fp ht_f1 ht_f2
+        (cvt_d hd.leftTy) (cvt_e he.leftTy),
+      IH.mono_r_2_ty hC_fJ ht_fJ ht_fJ' <| IH.join_ty hC_fp ht_f1 ht_f2
+        (cvt_d hd.rightTy) (cvt_e he.rightTy),
+      hd.leftDefEq, hd.rightDefEq⟩
   · exact IH.mono_r_2_ty hC_fJ ht_fJ ht_fJ' <| IH.join_ty hC_fp ht_f1 ht_f2
       (cvt_d (hE₁.2 d_ht ha c2)) (cvt_e (hE₂.2 e_ht ha c3))
 
@@ -5613,7 +12445,7 @@ def LRS.DefEq (IH : LogRel Γ n) (M N A : SExpr) (m a : WShape (n+1)) : Prop :=
       LRS.PiDefEq IH A₁ A₂ A₂ ⟨a₁, wfa1⟩ ⟨a₂, wfa2⟩ ∧
       LRS.LamDefEq IH M N A₁ A₂ ⟨mg, (hm ▸ m.2).1⟩ ⟨a₁, wfa1⟩ ⟨a₂, wfa2⟩
     | _ => False
-  | .indTy => True
+  | .indTy => LRS.IndDefEq Γ IH M N A m
   | _ => False
 
 @[simp] theorem LRS.DefEq.bot_a : LRS.DefEq IH M N A m .bot = True := rfl
@@ -5641,8 +12473,14 @@ def LRS.DefEq (IH : LogRel Γ n) (M N A : SExpr) (m a : WShape (n+1)) : Prop :=
 @[simp] theorem LRS.TyDefEq.lam_m : LRS.TyDefEq IH M N (.lam f hf) ↔ True := .rfl
 @[simp] theorem LRS.TyDefEq.ctor_m {c l h} :
     LRS.TyDefEq (n := n) IH M N (.ctor c l h) ↔ True := .rfl
-@[simp] theorem LRS.TyDefEq.indTy_m : LRS.TyDefEq (n := n) IH M N .indTy ↔ True := .rfl
-@[simp] theorem LRS.DefEq.indTy_a : LRS.DefEq (n := n) IH M N A m .indTy ↔ True := .rfl
+@[simp] theorem LRS.TyDefEq.indTy_m :
+    LRS.TyDefEq (n := n) (Γ := Γ) IH M N .indTy ↔
+      LRS.IndTyHead Γ M ∧ LRS.IndTyHead Γ N := by
+  rfl
+@[simp] theorem LRS.DefEq.indTy_a :
+    LRS.DefEq (n := n) (Γ := Γ) IH M N A m .indTy ↔
+      LRS.IndDefEq Γ IH M N A m := by
+  rfl
 
 def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
   DefEq := LRS.DefEq IH
@@ -5657,6 +12495,7 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
     · cases m using WShape.casesOn' with | lam => ?_ | _ => exact id
       intro ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, hP⟩
       exact ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, hP.left⟩
+    · exact LRS.IndDefEq.left
   symm_ty := .symm
   symm {M N A m a} := by
     dsimp [LRS.DefEq]; split <;> try trivial
@@ -5664,6 +12503,7 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
     · cases m using WShape.casesOn' with | lam => ?_ | _ => exact id
       intro ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, hP⟩
       exact ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, hP.symm⟩
+    · exact LRS.IndDefEq.symm
   trans_ty := .trans
   trans {M₁ M₂ A m a M₃} := by
     dsimp [LRS.DefEq]; split <;> try trivial
@@ -5672,29 +12512,50 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
       intro ⟨B, F, u, v, rA, hA1, hA2, hA₂, hE, hP⟩ ⟨_, _, _, _, rA', _, _, _, _, hP'⟩
       cases rA.determ .forallE rA' .forallE
       exact ⟨_, _, _, _, rA, hA1, hA2, hA₂, hE, hP.trans hP'⟩
+    · exact LRS.IndDefEq.trans
   trans' {A₁ A₂ u a s A₃ v r} := by
     dsimp [LRS.DefEq]; split <;> try intros; trivial
     · exact .trans
     · split <;> try intros; trivial
       intro ⟨_, _, _, _, rA, _⟩; cases WHNF.sort.whRedS rA
+    · intro h _
+      cases a using WShape.casesOn' with
+      | bot => trivial
+      | _ => exact h.1.not_sort.elim
   conv {A A' a M N m} := by
-    dsimp [LRS.TyDefEq]; dsimp [LRS.DefEq]; split <;> (try · simp); dsimp
-    intro ⟨B, F, B', F', u, v, rA, rA', hBB', hFF', hValB, hEdge⟩
-    cases m using WShape.casesOn' with | lam => ?_ | _ => exact id
-    intro ⟨_, _, _, v', rA₁, hA1, hValA, hA₂, hEdge₁, hP⟩
-    cases rA.determ .forallE rA₁ .forallE
-    refine ⟨_, _, _, _, rA', hBB'.hasType.2, IH.left_ty (IH.symm_ty hValB),
-      hBB'.defeqDF_l hFF'.hasType.2, ?_, ?_⟩
-    · refine ⟨fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩ <;>
-        have ha' := hBB'.symm.defeqDF ha
-      · exact and_self_iff.2 (hEdge.1 hp ha' (IH.conv (IH.symm_ty hValB) a1)).2
-      · exact (hEdge.1 hp ha' (IH.conv (IH.symm_ty hValB) a1)).2
-    refine ⟨fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩ <;> (
-      have a2 := IH.conv (IH.symm_ty hValB) a1
-      have ha' := hBB'.symm.defeqDF ha
-      have c := hEdge.2 hp ha'.hasType.1 (IH.left a2))
-    · have ⟨v1, v2⟩ := hP.1 hp ha' a2; exact ⟨IH.conv c v1, IH.conv c v2⟩
-    · exact IH.conv c (hP.2 hp ha' a2)
+    cases a using WShape.casesOn' with
+    | bot => intro _; exact id
+    | sort => intro _; exact id
+    | forallE a₁ a₂ =>
+      simp only [LRS.TyDefEq.forallE_iff]
+      intro ⟨B, F, B', F', u, v, rA, rA', hBB', hFF', hValB, hEdge⟩
+      cases m using WShape.casesOn' with | lam => ?_ | _ => exact id
+      simp only [LRS.DefEq.lam_forallE]
+      intro ⟨_, _, _, v', rA₁, hA1, hValA, hA₂, hEdge₁, hP⟩
+      cases rA.determ .forallE rA₁ .forallE
+      obtain ⟨u', hB'⟩ := hBB'.rightType
+      obtain ⟨v'', hF'⟩ := hFF'.rightType
+      obtain ⟨_, hBBsymm⟩ := hBB'.symm
+      refine ⟨_, _, u', v'', rA', hB', IH.left_ty (IH.symm_ty hValB),
+        hBB'.defeqDF_l hF', ?_, ?_⟩
+      · refine ⟨fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩ <;>
+          have ha' := hBBsymm.defeqDF ha
+        · let h := hEdge.1 hp ha' (IH.conv (IH.symm_ty hValB) a1)
+          exact ⟨h.rightTy, h.rightTy, h.rightDefEq, h.rightDefEq⟩
+        · exact (hEdge.1 hp ha' (IH.conv (IH.symm_ty hValB) a1)).rightTy
+      refine ⟨fun _ _ _ hp ha a1 => ?_, fun _ _ hp ha a1 => ?_⟩ <;> (
+        have a2 := IH.conv (IH.symm_ty hValB) a1
+        have ha' := hBBsymm.defeqDF ha
+        have c := hEdge.2 hp ha'.hasType.1 (IH.left a2))
+      · have ⟨v1, v2⟩ := hP.1 hp ha' a2; exact ⟨IH.conv c v1, IH.conv c v2⟩
+      · exact IH.conv c (hP.2 hp ha' a2)
+    | indTy =>
+      intro hTy hE
+      cases m using WShape.casesOn' with
+      | bot => trivial
+      | _ =>
+        exact ⟨hTy.2, hE.2⟩
+    | _ => intro _; exact id
   toType := id
   mono_r_2 {a a' M N A m} le hm ht h := by
     cases a using WShape.casesOn' with
@@ -5726,7 +12587,9 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
       | indTy => simp [LRS.DefEq.indTy_forallE] at h
     | lam f hf => exact absurd hm.isType WShape.HasType.lam_isType
     | ctor => exact absurd hm.isType WShape.HasType.ctor_isType
-    | indTy => simp [LRS.DefEq.indTy_a] at h ⊢
+    | indTy =>
+      cases WShape.indTy_le.1 le
+      exact h
   mono_r_2_ty {a a' A B} le ha ha' h := by
     cases a using WShape.casesOn' with
     | bot => trivial
@@ -5743,7 +12606,9 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
       exact hEdge.mono_r_2 le1 le2 hp hp' (IH.left_ty hValB)
     | lam f hf => simp [LRS.TyDefEq.lam_m]
     | ctor => simp [LRS.TyDefEq.ctor_m]
-    | indTy => simp [LRS.TyDefEq.indTy_m]
+    | indTy =>
+      cases WShape.indTy_le.1 le
+      exact h
   mono_r_1 {a a' A M N m} le ha ha' hA h := by
     cases a' using WShape.casesOn' with
     | bot => simp only [LRS.DefEq.bot_a]
@@ -5771,7 +12636,7 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
               let ⟨B₁, F₁, B₂, F₂, u', v', rA', rA'', hBB_tgt, hFF_tgt, hValB_tgt, hEdge_tgt⟩ := hA
               cases rA.determ .forallE rA' .forallE
               cases rA.determ .forallE rA'' .forallE
-              refine ⟨_, _, _, _, rA, hBB_tgt.hasType.1, hValB_tgt, hA₂, hEdge_tgt, ?_⟩
+              refine ⟨_, _, _, _, rA, hBB_tgt.leftType, hValB_tgt, hA₂, hEdge_tgt, ?_⟩
               exact hP.mono_r_1 le1 le2 hm_lam hm'_lam hEdge_tgt
             · cases hgf2
           · cases hgf'
@@ -5781,7 +12646,11 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
         | indTy => exact (LRS.DefEq.indTy_forallE.1 h).elim
     | lam f hf => exact absurd ha'.isType WShape.HasType.lam_isType
     | ctor => exact absurd ha'.isType WShape.HasType.ctor_isType
-    | indTy => simp [LRS.DefEq.indTy_a]
+    | indTy =>
+      obtain rfl | rfl := WShape.le_indTy.1 le
+      · have hm0 := ha.bot_r; subst m
+        trivial
+      · exact h
   mono_l {m m' M N A a} le hm hm' h := by
     cases a using WShape.casesOn' with
     | bot => simp only [LRS.DefEq.bot_a]
@@ -5803,7 +12672,9 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
           hEdge.mono_r_2 h1 h2 hm_pi hm'_pi (IH.left_ty hValB)⟩
       | lam => simp only [LRS.TyDefEq.lam_m]
       | ctor => simp only [LRS.TyDefEq.ctor_m]
-      | indTy => simp only [LRS.TyDefEq.indTy_m]
+      | indTy =>
+        cases WShape.indTy_le.1 le
+        exact h
     | forallE a₁ a₂ =>
       cases m using WShape.casesOn' with
       | bot => simp only [LRS.DefEq.bot_m]
@@ -5826,7 +12697,7 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
             cases WShape.le_bot.1 (hg'' ▸ le)
         · cases hgf'
       | _ => cases hm
-    | indTy => simp only [LRS.DefEq.indTy_a]
+    | indTy => exact h.mono_l le hm
     | _ => cases hm.isType
   join_ty {A B m₁ m₂} hC hm₁ hm₂ h1 h2 := by
     cases hm₁.unfold with
@@ -5851,7 +12722,11 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
       have ht₂ := (WShape.HasTypePi.iff.1 hp₂).1.isType
       refine ⟨B₁, F₁, B₂, F₂, u, v, rA, rB, hBB, hFF, IH.join_ty hC.1 ht₁ ht₂ hValB₁ hValB₂, ?_⟩
       exact .join ht₁ ht₂ hC.1 hp₁ hp₂ hC.2 hEdge₁ hEdge₂
-    | indTy => cases m₂ using WShape.casesOn' <;> trivial
+    | indTy =>
+      cases hm₂.unfold with
+      | bot => rwa [WShape.join_bot]
+      | indTy => exact ⟨h1.1, h2.2⟩
+      | _ => cases hC
   whr {M M' N N' A m a} hM hN := by
     cases a using WShape.casesOn' with
     | sort =>
@@ -5864,12 +12739,14 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
         constructor <;> intro ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, rest⟩
         · exact ⟨B₁, F₁, B₂, F₂, u, v, hM.determ_l rM .forallE, hN.determ_l rN .forallE, rest⟩
         · exact ⟨B₁, F₁, B₂, F₂, u, v, .trans hM rM, .trans hN rN, rest⟩
+      | indTy => exact and_congr (LRS.IndTyHead.whr hM) (LRS.IndTyHead.whr hN)
       | _ => rfl
     | forallE =>
       cases m using WShape.casesOn' with | lam => ?_ | _ => rfl
       constructor <;> intro ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, hP⟩
       · exact ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, (LRS.LamDefEq.whr hM hN).1 hP⟩
       · exact ⟨A₁, A₂, u, v, rA, hA1, hA2, hA₂, hE, (LRS.LamDefEq.whr hM hN).2 hP⟩
+    | indTy => exact LRS.IndDefEq.whr hM hN
     | _ => rfl
   whr_ty {A A' B B' m} hA hB := by
     cases m using WShape.casesOn' with
@@ -5881,6 +12758,7 @@ def LRS (IH : LogRel Γ n) : LogRel Γ (n+1) where
       constructor <;> intro ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, rest⟩
       · exact ⟨B₁, F₁, B₂, F₂, u, v, hA.determ_l rM .forallE, hB.determ_l rN .forallE, rest⟩
       · exact ⟨B₁, F₁, B₂, F₂, u, v, .trans hA rM, .trans hB rN, rest⟩
+    | indTy => exact and_congr (LRS.IndTyHead.whr hA) (LRS.IndTyHead.whr hB)
     | _ => rfl
 
 def LR (Γ : List SExpr) : LogRel Γ n :=
@@ -5891,30 +12769,351 @@ def LR (Γ : List SExpr) : LogRel Γ n :=
 @[simp] theorem LR_zero : LR (n := 0) Γ = LR0 := rfl
 @[simp] theorem LR_succ : LR (n := n+1) Γ = LRS (LR Γ) := rfl
 
+/-- The only non-structural case in successor-level semantic retyping.
+
+For bottom, sort, Pi, constructor, and inductive-type element shapes, the
+result type either is not inspected by `LRS.DefEq` or its required head is
+already supplied by type validity.  A lambda observation is different: its
+two typings may expose different Pi shapes, so transporting the stored
+`LamDefEq` package requires the merged inversion/uniqueness argument. -/
+def LogRel.LimitedUniq.LamRetype (IH : LogRel Γ n) : Prop :=
+  ∀ {x A B : SExpr} {f : WShapeFun n} {hf : f.NonZero}
+      {a b : WShape (n + 1)} {u : SLevel},
+    (WShape.lam f hf).HasType a →
+    (WShape.lam f hf).HasType b →
+    IsDefEq Γ x x A → IsDefEq Γ x x B →
+    (LRS IH).TyDefEq A A a → (LRS IH).TyDefEq B B b →
+    (LRS IH).DefEq x x A (WShape.lam f hf) a →
+    (LRS IH).DefEq x x B (WShape.lam f hf) b →
+    IsDefEq Γ A B (.sort u) →
+    ∀ {y : SExpr}, IsDefEq Γ x y B →
+      (LRS IH).DefEq x y B (WShape.lam f hf) b →
+      (LRS IH).DefEq x y A (WShape.lam f hf) a
+
+/-- A strong sufficient condition for lambda retyping: two arbitrary Pi-type
+observations related by one raw type equality admit a joined observation.
+
+This property is intentionally not part of `LR.JointBuilder`.  In general a
+type may have incompatible finite observations (already at the first positive
+level), whereas `LimitedUniq.LamRetype` only asks for the term-indexed
+transport actually consumed by successor uniqueness. -/
+def LogRel.PiTypeAlign (R : LogRel Γ (n + 1)) : Prop :=
+  ∀ {A B : SExpr} {a₁ b₁ : WShape n} {a₂ b₂ : WShapeFun n}
+      {u : SLevel},
+    IsDefEq Γ A B (.sort u) →
+    R.TyDefEq A A (.forallE a₁ a₂) →
+    R.TyDefEq B B (.forallE b₁ b₂) →
+    ∃ _compat : (WShape.forallE a₁ a₂).Compat (.forallE b₁ b₂),
+      R.TyDefEq A B ((WShape.forallE a₁ a₂).join (.forallE b₁ b₂))
+
+/-- Pi-type alignment supplies the sole non-structural lambda-retyping case. -/
+theorem LogRel.LimitedUniq.LamRetype.of_piTypeAlign
+    {IH : LogRel Γ n} (align : LogRel.PiTypeAlign (LRS IH)) :
+    LogRel.LimitedUniq.LamRetype IH := by
+  intro x A B f hf a b u hpA hpB _ _ htyA htyB _ _ hAB y _ hxy
+  obtain ⟨a₁, a₂, _, rfl⟩ := WShape.HasType.lam_l.1 hpA
+  obtain ⟨b₁, b₂, _, rfl⟩ := WShape.HasType.lam_l.1 hpB
+  obtain ⟨compat, hTy⟩ := align hAB htyA htyB
+  exact LogRel.DefEq.retype_join compat hpA hpB hTy hxy
+
+/-- Successor-level limited uniqueness decomposes into raw weak type
+uniqueness and exactly one lambda-retyping case.  This theorem discharges
+all other element shapes definitionally or from the supplied semantic type
+validity, making the former L4L-17 obligation consumed by the joint tower
+explicit and minimal. -/
+theorem LRS.limitedUniq_of_typeUniq
+    {IH : LogRel Γ n}
+    (typeUniq : LogRel.RawTypeUniq Γ)
+    (lamRetype : LogRel.LimitedUniq.LamRetype IH) :
+    LogRel.LimitedUniq (LRS IH) where
+  align := by
+    intro x A B p a b hpA hpB hxA hxB htyA htyB hxxA hxxB
+    obtain ⟨u, hAB⟩ := typeUniq hxA hxB
+    refine ⟨u, hAB, ?_⟩
+    cases p using WShape.casesOn' with
+    | bot =>
+      intro y _ _
+      exact (LRS IH).bot hpA.isType
+    | sort r =>
+      cases a using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpA
+      cases b using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpB
+      intro y _ hxy
+      change LRS.TyDefEq IH x y (WShape.sort r)
+      change LRS.TyDefEq IH x y (WShape.sort r) at hxy
+      exact hxy
+    | forallE d c =>
+      obtain ⟨_, _, rfl⟩ := WShape.HasType.forallE_l.1 hpA
+      obtain ⟨_, _, rfl⟩ := WShape.HasType.forallE_l.1 hpB
+      intro y _ hxy
+      change LRS.TyDefEq IH x y (WShape.forallE d c)
+      change LRS.TyDefEq IH x y (WShape.forallE d c) at hxy
+      exact hxy
+    | lam f hf =>
+      exact lamRetype hpA hpB hxA hxB htyA htyB hxxA hxxB hAB
+    | ctor c fields hwf =>
+      cases a using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpA
+      cases b using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpB
+      intro y _ hxy
+      exact ⟨htyA.1, hxy.2⟩
+    | indTy =>
+      cases a using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpA
+      cases b using WShape.casesOn' <;>
+        simp [WShape.HasType, WShape.bot, WShape.sort, WShape.forallE,
+          WShape.lam, WShape.ctor, WShape.indTy, Shape.HasType,
+          Shape.hasType] at hpB
+      intro y _ hxy
+      change LRS.TyDefEq IH x y WShape.indTy
+      change LRS.TyDefEq IH x y WShape.indTy at hxy
+      exact hxy
+
+/-- Optional adapter from the stronger Pi-observation alignment property.
+The joint tower consumes `LamRetype` directly; this theorem remains useful to
+callers that happen to have compatible observations for independent reasons. -/
+theorem LRS.limitedUniq_of_typeUniq_of_piTypeAlign
+    {IH : LogRel Γ n}
+    (typeUniq : LogRel.RawTypeUniq Γ)
+    (align : LogRel.PiTypeAlign (LRS IH)) :
+    LogRel.LimitedUniq (LRS IH) :=
+  LRS.limitedUniq_of_typeUniq typeUniq
+    (LogRel.LimitedUniq.LamRetype.of_piTypeAlign align)
+
+/-- Apply functions related one stratum above `IH` to arguments related in
+`IH`.  `LamDefEq` stores the two same-head congruences and the same-argument
+cross-head equality separately; their composition is the ordinary
+heterogeneous application rule.  Keeping this statement polymorphic in
+`IH` is essential for consumers of `CtorDefEq.fold`, whose lift and unlift
+branches temporarily replace the canonical logical relation by an
+equivalent one. -/
+theorem LRS.DefEq.app
+    {n : Nat} {M N A₁ A₂ x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    {IH : LogRel Γ n}
+    (hfun : (LRS IH).DefEq M N (.forallE A₁ A₂)
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) (hxy : Γ ⊢ x ≡ y : A₁)
+    (harg : IH.DefEq x y A₁ p b) :
+    IH.DefEq (M.app x) (N.app y) (A₂.inst x)
+      (mf.app p) (tf.app p) := by
+  change LRS.DefEq IH M N (.forallE A₁ A₂)
+    (.lam mf hmf) (.forallE b tf) at hfun
+  rw [LRS.DefEq.lam_forallE] at hfun
+  obtain ⟨B, F, u, v, hred, hB, hValB, hF, hPi, hLam⟩ := hfun
+  have hhead : SExpr.forallE A₁ A₂ = SExpr.forallE B F :=
+    WHNF.forallE.whRedS hred
+  cases hhead
+  exact IH.trans
+    (hLam.2 hp hxy.hasType.1 (IH.left harg))
+    (hLam.1 hp hxy harg).2
+
+/-- Apply a synchronized rectangle of related functions to one related
+argument pair.  All three result edges use the same argument observation and
+the same left-oriented dependent codomain, so later retyping cannot silently
+mix endpoint witnesses selected at different shapes. -/
+theorem LRS.DefEqRect.app
+    {n : Nat} {M₁ M₂ N₁ N₂ A₁ A₂ x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    {IH : LogRel Γ n}
+    (hfun : LogRel.DefEqRect (LRS IH)
+      M₁ M₂ N₁ N₂ (.forallE A₁ A₂)
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) (hxy : Γ ⊢ x ≡ y : A₁)
+    (harg : IH.DefEq x y A₁ p b) :
+    LogRel.DefEqRect IH
+      (M₁.app x) (M₂.app y) (N₁.app x) (N₂.app y)
+      (A₂.inst x) (mf.app p) (tf.app p) :=
+  ⟨LRS.DefEq.app hfun.left hp hxy harg,
+    LRS.DefEq.app hfun.right hp hxy harg,
+    LRS.DefEq.app hfun.cross hp hxy harg⟩
+
+/-- Expose the Pi telescope stored by a function relation whose declared
+type is not syntactically a Pi, then apply it at that exact exposed domain.
+
+This is the conversion-safe one-step interface used by path-indexed
+application spines: raw `PathSpineWF.conv` edges are not converted into a
+semantic type equality prematurely.  Instead the logical function
+observation selects its own weak-head Pi telescope, and a later alignment
+step reconciles that domain with the path-selected capture type. -/
+theorem LRS.DefEq.app_exposed
+    {n : Nat} {M N T x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    {IH : LogRel Γ n}
+    (hfun : (LRS IH).DefEq M N T
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) :
+    ∃ B F u v, WHRedS Γ T (.forallE B F) ∧
+      Γ ⊢ B : .sort u ∧ IH.TyDefEq B B b ∧
+      B :: Γ ⊢ F : .sort v ∧
+      LRS.PiDefEq IH B F F b tf ∧
+      ∀ (_hxy : Γ ⊢ x ≡ y : B),
+        IH.DefEq x y B p b →
+        IH.DefEq (M.app x) (N.app y) (F.inst x)
+          (mf.app p) (tf.app p) := by
+  change LRS.DefEq IH M N T
+    (.lam mf hmf) (.forallE b tf) at hfun
+  rw [LRS.DefEq.lam_forallE] at hfun
+  obtain ⟨B, F, u, v, hred, hB, hValB, hF, hPi, hLam⟩ := hfun
+  refine ⟨B, F, u, v, hred, hB, hValB, hF, hPi, ?_⟩
+  intro hxy harg
+  exact IH.trans
+    (hLam.2 hp hxy.hasType.1 (IH.left harg))
+    (hLam.1 hp hxy harg).2
+
+/-- Rectangle form of `LRS.DefEq.app_exposed`.
+
+Weak-head determinism identifies the three Pi telescopes selected by the
+left, right, and cross edges before any application is performed.  The
+result therefore keeps one left-oriented dependent codomain across the
+whole synchronized rectangle. -/
+theorem LRS.DefEqRect.app_exposed
+    {n : Nat} {M₁ M₂ N₁ N₂ T x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    {IH : LogRel Γ n}
+    (hfun : LogRel.DefEqRect (LRS IH)
+      M₁ M₂ N₁ N₂ T
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) :
+    ∃ B F u v, WHRedS Γ T (.forallE B F) ∧
+      Γ ⊢ B : .sort u ∧ IH.TyDefEq B B b ∧
+      B :: Γ ⊢ F : .sort v ∧
+      LRS.PiDefEq IH B F F b tf ∧
+      ∀ (_hxy : Γ ⊢ x ≡ y : B),
+        IH.DefEq x y B p b →
+        LogRel.DefEqRect IH
+          (M₁.app x) (M₂.app y) (N₁.app x) (N₂.app y)
+          (F.inst x) (mf.app p) (tf.app p) := by
+  have hleft := hfun.left
+  have hright := hfun.right
+  have hcross := hfun.cross
+  change LRS.DefEq IH M₁ M₂ T
+    (.lam mf hmf) (.forallE b tf) at hleft
+  change LRS.DefEq IH N₁ N₂ T
+    (.lam mf hmf) (.forallE b tf) at hright
+  change LRS.DefEq IH M₁ N₂ T
+    (.lam mf hmf) (.forallE b tf) at hcross
+  rw [LRS.DefEq.lam_forallE] at hleft hright hcross
+  obtain ⟨BL, FL, uL, vL, hredL, hBL, hValBL, hFL, hPiL, hLamL⟩ := hleft
+  obtain ⟨BR, FR, _, _, hredR, _, _, _, _, hLamR⟩ := hright
+  obtain ⟨BC, FC, _, _, hredC, _, _, _, _, hLamC⟩ := hcross
+  have hLR : SExpr.forallE BL FL = .forallE BR FR :=
+    hredL.determ .forallE hredR .forallE
+  have hLC : SExpr.forallE BL FL = .forallE BC FC :=
+    hredL.determ .forallE hredC .forallE
+  cases hLR
+  cases hLC
+  refine ⟨BL, FL, uL, vL, hredL, hBL, hValBL, hFL, hPiL, ?_⟩
+  intro hxy harg
+  exact ⟨
+    IH.trans (hLamL.2 hp hxy.hasType.1 (IH.left harg))
+      (hLamL.1 hp hxy harg).2,
+    IH.trans (hLamR.2 hp hxy.hasType.1 (IH.left harg))
+      (hLamR.1 hp hxy harg).2,
+    IH.trans (hLamC.2 hp hxy.hasType.1 (IH.left harg))
+      (hLamC.1 hp hxy harg).2⟩
+
+/-- Canonical specialization of `LRS.DefEq.app`. -/
+theorem LR.DefEq.app
+    {n : Nat} {M N A₁ A₂ x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    (hfun : (LR Γ).DefEq M N (.forallE A₁ A₂)
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) (hxy : Γ ⊢ x ≡ y : A₁)
+    (harg : (LR Γ).DefEq x y A₁ p b) :
+    (LR Γ).DefEq (M.app x) (N.app y) (A₂.inst x)
+      (mf.app p) (tf.app p) := by
+  rw [LR_succ] at hfun
+  exact LRS.DefEq.app hfun hp hxy harg
+
+/-- Canonical specialization of `LRS.DefEqRect.app`. -/
+theorem LR.DefEqRect.app
+    {n : Nat} {M₁ M₂ N₁ N₂ A₁ A₂ x y : SExpr}
+    {mf : WShapeFun n} {hmf : mf.NonZero}
+    {b p : WShape n} {tf : WShapeFun n}
+    (hfun : LogRel.DefEqRect (LR Γ)
+      M₁ M₂ N₁ N₂ (.forallE A₁ A₂)
+      (.lam mf hmf) (.forallE b tf))
+    (hp : p.HasType b) (hxy : Γ ⊢ x ≡ y : A₁)
+    (harg : (LR Γ).DefEq x y A₁ p b) :
+    LogRel.DefEqRect (LR Γ)
+      (M₁.app x) (M₂.app y) (N₁.app x) (N₂.app y)
+      (A₂.inst x) (mf.app p) (tf.app p) := by
+  rw [LR_succ] at hfun
+  exact LRS.DefEqRect.app hfun hp hxy harg
+
+/-- An ordinary constructor observation has inductive type, so a logical-
+relation witness at its exact `ctor'` shape exposes the observable
+`CtorDefEq` evidence.  The classification hypothesis matters here:
+`ctor'` is allowed to collapse an eta-constructor whose fields are all
+bottom, but an iota pattern's constructor is classified as `.ctor`. -/
+theorem LR.DefEq.ctor'_inv
+    {n : Nat} {c : Name} {fields : List (WShape n)}
+    {M N A : SExpr} {a : WShape (n + 1)}
+    (hcl : Params.classify c = some (.ctor fields.length))
+    (ht : (WShape.ctor' c fields).HasType a)
+    (H : (LR Γ).DefEq M N A (WShape.ctor' c fields) a) :
+    LRS.IndTyHead Γ A ∧
+      LRS.CtorDefEq Γ (LR Γ) M N (WShape.ctor' c fields) := by
+  have hwf : IsStruct c → WShape.ListNonZero fields := by
+    simp [IsStruct, hcl]
+  rw [WShape.ctor', dif_pos hwf] at ht H
+  have ha : a = WShape.indTy := by
+    apply WShape.ext
+    change Shape.hasType (n := n + 1)
+      (ShapeS.ctor c (fields.map fun x : WShape n => x.1)) a.1 at ht
+    cases ha : a.1 <;> simp [ha, Shape.hasType, WShape.indTy] at ht ⊢
+  subst a
+  rw [LR_succ] at H
+  change LRS.IndDefEq Γ (LR Γ) M N A (WShape.ctor c fields hwf) at H
+  have hctor : WShape.ctor' c fields = WShape.ctor c fields hwf := by
+    exact WShape.ctor_eq_ctor'.symm
+  rw [hctor]
+  simpa [LRS.IndDefEq, WShape.ctor] using H
+
 private theorem LRS.PiDefEq.lift_aux
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'}
     {b : WShape n} {f : WShapeFun n} (le : n ≤ n') (htpi_a : WShape.HasTypePi f b true)
     (IH1 : ∀ {M N : SExpr} {m : WShape n}, WShape.HasType m .type →
-      ((LR Γ).TyDefEq M N (m.lift n') ↔ (LR Γ).TyDefEq M N m))
+      (IH'.TyDefEq M N (m.lift n') ↔ IH.TyDefEq M N m))
     (IH2 : ∀ {M N A : SExpr} {m a : WShape n}, WShape.HasType m a →
-      ((LR Γ).DefEq M N A (m.lift n') (a.lift _) ↔ (LR Γ).DefEq M N A m a)) :
-    LRS.PiDefEq (LR Γ) B F₁ F₂ (b.lift n') (f.lift n') ↔
-    LRS.PiDefEq (LR Γ) B F₁ F₂ b f := by
+      (IH'.DefEq M N A (m.lift n') (a.lift _) ↔ IH.DefEq M N A m a)) :
+    LRS.PiDefEq IH' B F₁ F₂ (b.lift n') (f.lift n') ↔
+    LRS.PiDefEq IH B F₁ F₂ b f := by
   have htpi_w := WShape.HasTypePi.iff.1 htpi_a
   constructor <;> intro hEdge
   · refine ⟨fun _ _ _ hp ha v => ?_, fun _ _ hp ha v => ?_⟩ <;> (
       have hp' := (WShape.HasType.lift le).2 hp
       have v' := (IH2 hp).2 v)
-    · have ⟨r1, r2⟩ := hEdge.1 hp' ha v'
-      exact ⟨(IH1 (htpi_w.2 _ hp)).1 (WShapeFun.lift_app le ▸ r1),
-             (IH1 (htpi_w.2 _ hp)).1 (WShapeFun.lift_app le ▸ r2)⟩
+    · have h := hEdge.1 hp' ha v'
+      exact ⟨(IH1 (htpi_w.2 _ hp)).1 (WShapeFun.lift_app le ▸ h.leftTy),
+        (IH1 (htpi_w.2 _ hp)).1 (WShapeFun.lift_app le ▸ h.rightTy),
+        h.leftDefEq, h.rightDefEq⟩
     · exact (IH1 (htpi_w.2 _ hp)).1 (WShapeFun.lift_app le ▸ hEdge.2 hp' ha v')
   · refine ⟨fun _ _ _ hp ha v => ?_, fun _ _ hp ha v => ?_⟩ <;> (
       obtain ⟨q, d1, d2⟩ := WShapeFun.app_eq (f.lift n') _
       obtain ⟨q₀, y₀, d2₀, rfl, d3⟩ := (WShapeFun.mem_lift le).1 d2
       obtain ⟨qx', qy', d2₀', qxle, qyle, hq⟩ := WShape.HasDom.def.1 htpi_a.1 _ _ d2₀
-      have v' := (IH2 hq).1 ((LR Γ).mono_l (((WShape.lift_le_lift le).2 qxle).trans d1)
+      have v' := (IH2 hq).1 (IH'.mono_l (((WShape.lift_le_lift le).2 qxle).trans d1)
         ((WShape.HasType.lift le).2 hq) hp v))
-    · have ⟨r1, r2⟩ := hEdge.1 hq ha v'
+    · have h := hEdge.1 hq ha v'
       have ht_q := (htpi_w.2 _ hq).toType
       have ht_y₀ : (y₀ : WShape n).HasType WShape.type := (htpi_a.2 _ _ d2₀).toType
       have y₀_le_fqx : y₀ ≤ f.app qx' := qyle.trans (f.app_of_mem d2₀').2
@@ -5923,8 +13122,11 @@ private theorem LRS.PiDefEq.lift_aux
       have ht_y₀_l : (y₀.lift n').HasType WShape.type := by
         have := (WShape.HasType.lift le).2 ht_y₀; rwa [WShape.lift_sort] at this
       exact d3 ▸ ⟨
-        (LR Γ).mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l ((IH1 ht_q).2 r1),
-        (LR Γ).mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l ((IH1 ht_q).2 r2)⟩
+        IH'.mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l
+          ((IH1 ht_q).2 h.leftTy),
+        IH'.mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l
+          ((IH1 ht_q).2 h.rightTy),
+        h.leftDefEq, h.rightDefEq⟩
     · have hq_body := hEdge.2 hq ha v'
       have ht_q := (htpi_w.2 _ hq).toType
       have ht_y₀ : (y₀ : WShape n).HasType WShape.type := (htpi_a.2 _ _ d2₀).toType
@@ -5934,24 +13136,36 @@ private theorem LRS.PiDefEq.lift_aux
       have ht_y₀_l : (y₀.lift n').HasType WShape.type := by
         have := (WShape.HasType.lift le).2 ht_y₀; rwa [WShape.lift_sort] at this
       exact d3 ▸
-        (LR Γ).mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l ((IH1 ht_q).2 hq_body)
+        IH'.mono_r_2_ty (WShape.lift_mono le y₀_le_fqx) ht_y₀_l ht_q_l ((IH1 ht_q).2 hq_body)
+
+/-- Rebase a Pi edge through the packaged equivalence carried by a
+normalized constructor frame. -/
+theorem LRS.PiDefEq.liftEquiv
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+    {b : WShape n} {f : WShapeFun n} (le : n ≤ n')
+    (htpi : WShape.HasTypePi f b true)
+    (E : LogRel.LiftEquiv IH IH' le) :
+    LRS.PiDefEq IH' B F₁ F₂ (b.lift n') (f.lift n') ↔
+      LRS.PiDefEq IH B F₁ F₂ b f :=
+  LRS.PiDefEq.lift_aux le htpi E.ty E.term
 
 private theorem LRS.LamDefEq.lift_aux
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'}
     {g : WShapeFun n} {a₁ a₂} (le : n ≤ n') (htm : WShape.HasTypeLam g a₁ a₂)
-    (IH : ∀ {M N A : SExpr} {m a : WShape n}, WShape.HasType m a →
-      ((LR Γ).DefEq M N A (m.lift n') (a.lift _) ↔ (LR Γ).DefEq M N A m a))
-    (hEdge : LRS.PiDefEq (LR Γ) A₁ A₂ A₂ a₁ a₂) :
-    LRS.LamDefEq (LR Γ) (n := n') M N A₁ A₂ (g.lift n') (a₁.lift n') (a₂.lift n') ↔
-    LRS.LamDefEq (LR Γ) M N A₁ A₂ g a₁ a₂ := by
+    (IHDef : ∀ {M N A : SExpr} {m a : WShape n}, WShape.HasType m a →
+      (IH'.DefEq M N A (m.lift n') (a.lift _) ↔ IH.DefEq M N A m a))
+    (hEdge : LRS.PiDefEq IH A₁ A₂ A₂ a₁ a₂) :
+    LRS.LamDefEq IH' M N A₁ A₂ (g.lift n') (a₁.lift n') (a₂.lift n') ↔
+    LRS.LamDefEq IH M N A₁ A₂ g a₁ a₂ := by
   have htm_w := WShape.HasTypeLam.iff.1 htm
   constructor <;> intro hP
   · refine ⟨fun _ _ _ hp ha v => ?_, fun _ _ hp ha v => ?_⟩ <;> (
       have hp' := (WShape.HasType.lift le).2 hp
-      have v' := (IH hp).2 v)
+      have v' := (IHDef hp).2 v)
     · have ⟨r1, r2⟩ := hP.1 hp' ha v'
-      refine ⟨(IH (htm_w.2.2 _ hp)).1 ?_, (IH (htm_w.2.2 _ hp)).1 ?_⟩
+      refine ⟨(IHDef (htm_w.2.2 _ hp)).1 ?_, (IHDef (htm_w.2.2 _ hp)).1 ?_⟩
         <;> rw [WShapeFun.lift_app le, WShapeFun.lift_app le] <;> [exact r1; exact r2]
-    · apply (IH (htm_w.2.2 _ hp)).1
+    · apply (IHDef (htm_w.2.2 _ hp)).1
       rw [WShapeFun.lift_app le, WShapeFun.lift_app le]
       exact hP.2 hp' ha v'
   · refine ⟨fun a' b' p hp ha v => ?_, fun a' p hp ha v => ?_⟩
@@ -5965,14 +13179,14 @@ private theorem LRS.LamDefEq.lift_aux
       have ⟨qg', qg'le, hqg, qg'app⟩ := WShape.HasDom.iff.1 htm.2.1 qg
       have ⟨qa', qa'le, hqa, qa'app⟩ := WShape.HasDom.iff.1 htm.1.1 qa
       rw [dg3, da3]
-      have v_lo := (IH hqg).1 <| (LR Γ).mono_l
+      have v_lo := (IHDef hqg).1 <| IH'.mono_l
         (((WShape.lift_le_lift le).2 qg'le).trans dg1) ((WShape.HasType.lift le).2 hqg) hp v
-      have v_lo_qa := (IH hqa).1 <| (LR Γ).mono_l
+      have v_lo_qa := (IHDef hqa).1 <| IH'.mono_l
         (((WShape.lift_le_lift le).2 qa'le).trans da1) ((WShape.HasType.lift le).2 hqa) hp v
       have ht_lo := htm_w.2.2 _ hqg
       have htm_p := WShape.HasTypePi.iff'.1 htm_w.1
-      have vt_qa := hEdge.2 hqa ha.hasType.1 ((LR Γ).left v_lo_qa)
-      have vt_qa' := (LR Γ).mono_r_2_ty qa'app (htm_p.2 qa) (htm_p.2 qa') vt_qa
+      have vt_qa := hEdge.2 hqa ha.hasType.1 (IH.left v_lo_qa)
+      have vt_qa' := IH.mono_r_2_ty qa'app (htm_p.2 qa) (htm_p.2 qa') vt_qa
       have ya_sort := (htm_p.2 qa).mono_l ya₁ ya₂
       have ht_yg_qg' : yg.HasType (a₂.app qg') :=
         ht_lo.mono_l (WShapeFun.app_mono_r qg'le |>.trans yg₁) (yg₂.trans qg'app)
@@ -5982,15 +13196,98 @@ private theorem LRS.LamDefEq.lift_aux
         exact (WShapeFun.app_mono_r dg1 (f := a₂.lift n')).trans <| da3 ▸ WShape.lift_mono le ya₂
       have ya_sort := (htm_p.2 qa).mono_l ya₁ ya₂
       have ht_yg := ya_sort.mono_r le_a2_ya ht_yg_qg'
-      have vt_ya := (LR Γ).mono_r_2_ty ya₂ ya_sort (htm_p.2 qa) vt_qa'
-      have go {M N} (r : (LR Γ).DefEq M N (A₂.inst a') (g.app qg') (a₂.app qg')) :
-          (LR Γ).DefEq M N (A₂.inst a') (yg.lift n') (ya.lift n') :=
-        (IH ht_yg).2 <|
-        (LR Γ).mono_r_1 le_a2_ya ht_yg_qg' ht_yg vt_ya <|
-        (LR Γ).mono_l (yg₂.trans qg'app) ht_yg_qg' ht_lo r
+      have vt_ya := IH.mono_r_2_ty ya₂ ya_sort (htm_p.2 qa) vt_qa'
+      have go {M N} (r : IH.DefEq M N (A₂.inst a') (g.app qg') (a₂.app qg')) :
+          IH'.DefEq M N (A₂.inst a') (yg.lift n') (ya.lift n') :=
+        (IHDef ht_yg).2 <|
+        IH.mono_r_1 le_a2_ya ht_yg_qg' ht_yg vt_ya <|
+        IH.mono_l (yg₂.trans qg'app) ht_yg_qg' ht_lo r
     · have ⟨r1, r2⟩ := hP.1 hqg ha v_lo; exact ⟨go r1, go r2⟩
     · exact go (hP.2 hqg ha v_lo)
 
+/-- Transport the successor type relation along an arbitrary lower-relation
+equivalence.  This is the continuation law required by constructor
+observations that cross shape levels. -/
+theorem LRS.TyDefEq.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+    (le : n ≤ n')
+    (IH1 : ∀ {M N : SExpr} {m : WShape n}, m.HasType .type →
+      (IH'.TyDefEq M N (m.lift n') ↔ IH.TyDefEq M N m))
+    (IH2 : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a))
+    {m : WShape (n + 1)} (hmt : m.HasType .type) :
+    LRS.TyDefEq IH' M N (m.lift (n' + 1)) ↔
+      LRS.TyDefEq IH M N m := by
+  cases m using WShape.casesOn' with
+  | bot => rw [WShape.lift_bot]; rfl
+  | sort r => rw [WShape.lift_sort]; rfl
+  | forallE b f =>
+    rw [WShape.lift_forallE le]
+    have ⟨_, htpi, rfl⟩ := WShape.HasType.forallE_l.1 hmt
+    constructor <;>
+      intro ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, hB, hF, hValB, hE⟩ <;>
+      refine ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, hB, hF, ?_, ?_⟩
+    · exact (IH1 (WShape.HasTypePi.iff.1 htpi).1.isType).1 hValB
+    · exact (LRS.PiDefEq.lift_aux le htpi IH1 IH2).1 hE
+    · exact (IH1 (WShape.HasTypePi.iff.1 htpi).1.isType).2 hValB
+    · exact (LRS.PiDefEq.lift_aux le htpi IH1 IH2).2 hE
+  | lam f h => rw [WShape.lift_lam le]; rfl
+  | ctor c l h => rw [WShape.lift_ctor le]; rfl
+  | indTy => rw [WShape.lift_indTy]; rfl
+
+/-- Transport the full successor term relation along arbitrary term- and
+type-relation lift equivalences. -/
+theorem LRS.DefEq.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'}
+    (le : n ≤ n')
+    (IH1 : ∀ {M N : SExpr} {m : WShape n}, m.HasType .type →
+      (IH'.TyDefEq M N (m.lift n') ↔ IH.TyDefEq M N m))
+    (IH2 : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a))
+    {m a : WShape (n + 1)} (hma : m.HasType a) :
+    LRS.DefEq IH' M N A (m.lift (n' + 1)) (a.lift (n' + 1)) ↔
+      LRS.DefEq IH M N A m a := by
+  cases a using WShape.casesOn' with
+  | bot => rw [WShape.lift_bot]; rfl
+  | sort r =>
+    rw [WShape.lift_sort]
+    exact LRS.TyDefEq.lift le IH1 IH2 hma.toType
+  | indTy =>
+    rw [WShape.lift_indTy]
+    exact LRS.IndDefEq.lift le IH1 IH2
+  | forallE a₁ a₂ =>
+    have ⟨_, htpi_a, _⟩ := WShape.HasType.forallE_l.1 hma.isType
+    obtain ⟨g, rfl, htm⟩ := WShape.HasType.forallE_inv hma
+    unfold WShape.lam'
+    split
+    · rw [WShape.lift_lam le, WShape.lift_forallE le]
+      simp only [LRS.DefEq.lam_forallE]
+      constructor <;>
+        intro ⟨A₁, A₂, u, v, rA, hA1, hValA, hA₂, hEdge, hP⟩
+      · have hEdge' := (LRS.PiDefEq.lift_aux le htm.1 IH1 IH2).1 hEdge
+        exact ⟨A₁, A₂, u, v, rA, hA1,
+          (IH1 (WShape.HasTypePi.iff.1 htpi_a).1.isType).1 hValA,
+          hA₂, hEdge', (LRS.LamDefEq.lift_aux le htm IH2 hEdge').1 hP⟩
+      · have hEdge' := (LRS.PiDefEq.lift_aux le htm.1 IH1 IH2).2 hEdge
+        exact ⟨A₁, A₂, u, v, rA, hA1,
+          (IH1 (WShape.HasTypePi.iff.1 htpi_a).1.isType).2 hValA,
+          hA₂, hEdge', (LRS.LamDefEq.lift_aux le htm IH2 hEdge).2 hP⟩
+    · rw [WShape.lift_forallE le]
+      rfl
+  | _ => cases hma.isType
+
+/-- Lift a packaged relation equivalence through one `LRS` layer. -/
+def LogRel.LiftEquiv.succ
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} {le : n ≤ n'}
+    (E : LogRel.LiftEquiv IH IH' le) :
+    LogRel.LiftEquiv (LRS IH) (LRS IH') (Nat.succ_le_succ le) where
+  ty := by
+    intro A B a ha
+    exact LRS.TyDefEq.lift le E.ty E.term ha
+  term := by
+    intro M N A m a hma
+    exact LRS.DefEq.lift le E.ty E.term hma
+
 private theorem LR.lift_succ_aux :
     (∀ {M N : SExpr} {m : WShape n}, WShape.HasType m .type →
       (LRS.TyDefEq (n := n) (LR Γ) M N (m.lift _) ↔ (LR Γ).TyDefEq M N m)) ∧
@@ -6005,18 +13302,31 @@ private theorem LR.lift_succ_aux :
     refine have h1 := ?_; ⟨h1, ?_⟩
     · intro M N m hmt
       cases m using WShape.casesOn' with
-      | forallE b f => ?_ | _ => constructor <;> intro <;> trivial
+      | forallE b f => ?_
+      | indTy =>
+        change LRS.TyDefEq (LR Γ) M N ((WShape.indTy : WShape (k+1)).lift (k+2)) ↔ _
+        rw [WShape.lift_indTy]
+        rw [LR_succ]
+        change (LRS.IndTyHead Γ M ∧ LRS.IndTyHead Γ N) ↔
+          (LRS.IndTyHead Γ M ∧ LRS.IndTyHead Γ N)
+        rfl
+      | _ => constructor <;> intro <;> trivial
       rw [WShape.lift_forallE (Nat.le_succ k)]
       have ⟨_, htpi, rfl⟩ := WShape.HasType.forallE_l.1 hmt
       constructor <;> intro ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, hB, hF, hValB, hE⟩ <;>
         refine ⟨B₁, F₁, B₂, F₂, u, v, rM, rN, hB, hF, ?_, ?_⟩
       · exact (ih.1 (WShape.HasTypePi.iff.1 htpi).1.isType).1 hValB
-      · exact (LRS.PiDefEq.lift_aux (Nat.le_succ k) htpi ih.1 ih.2).1 hE
+      · exact (LRS.PiDefEq.lift_aux (IH := LR Γ) (IH' := LRS (LR Γ))
+          (Nat.le_succ k) htpi ih.1 ih.2).1 hE
       · exact (ih.1 (WShape.HasTypePi.iff.1 htpi).1.isType).2 hValB
-      · exact (LRS.PiDefEq.lift_aux (Nat.le_succ k) htpi ih.1 ih.2).2 hE
+      · exact (LRS.PiDefEq.lift_aux (IH := LR Γ) (IH' := LRS (LR Γ))
+          (Nat.le_succ k) htpi ih.1 ih.2).2 hE
     · intro M N A m a hma
       cases a using WShape.casesOn' with
-      | bot | indTy => constructor <;> intro <;> trivial
+      | bot => constructor <;> intro <;> trivial
+      | indTy =>
+        rw [WShape.lift_indTy]
+        exact LRS.IndDefEq.lift (Nat.le_succ k) ih.1 ih.2
       | sort => exact h1 hma.toType
       | forallE a₁ a₂ => ?_ | _ => cases hma.isType
       have ⟨_, htpi_a, _⟩ := WShape.HasType.forallE_l.1 hma.isType
@@ -6025,13 +13335,19 @@ private theorem LR.lift_succ_aux :
       rw [WShape.lift_lam (Nat.le_succ k), WShape.lift_forallE (Nat.le_succ k)]
       simp only [LRS.DefEq.lam_forallE]
       constructor <;> intro ⟨A₁, A₂, u, v, rA, hA1, hValA, hA₂, hEdge, hP⟩ <;>
-        [ have hEdge' := (LRS.PiDefEq.lift_aux (Nat.le_succ k) htm.1 ih.1 ih.2).1 hEdge;
-          have hEdge' := (LRS.PiDefEq.lift_aux (Nat.le_succ k) htm.1 ih.1 ih.2).2 hEdge ] <;>
+        [ have hEdge' := (LRS.PiDefEq.lift_aux
+            (IH := LR Γ) (IH' := LRS (LR Γ))
+            (Nat.le_succ k) htm.1 ih.1 ih.2).1 hEdge;
+          have hEdge' := (LRS.PiDefEq.lift_aux
+            (IH := LR Γ) (IH' := LRS (LR Γ))
+            (Nat.le_succ k) htm.1 ih.1 ih.2).2 hEdge ] <;>
         refine ⟨A₁, A₂, u, v, rA, hA1, ?_, hA₂, hEdge', ?_⟩
       · exact (ih.1 (WShape.HasTypePi.iff.1 htpi_a).1.isType).1 hValA
-      · exact (LRS.LamDefEq.lift_aux (Nat.le_succ k) htm ih.2 hEdge').1 hP
+      · exact (LRS.LamDefEq.lift_aux (IH := LR Γ) (IH' := LRS (LR Γ))
+          (Nat.le_succ k) htm ih.2 hEdge').1 hP
       · exact (ih.1 (WShape.HasTypePi.iff.1 htpi_a).1.isType).2 hValA
-      · exact (LRS.LamDefEq.lift_aux (Nat.le_succ k) htm ih.2 hEdge).2 hP
+      · exact (LRS.LamDefEq.lift_aux (IH := LR Γ) (IH' := LRS (LR Γ))
+          (Nat.le_succ k) htm ih.2 hEdge).2 hP
 
 theorem LR.DefEq.lift {m a : WShape n} (le : n ≤ n') (hma : WShape.HasType m a) :
     (LR Γ).DefEq M N A (m.lift n') (a.lift _) ↔ (LR Γ).DefEq M N A m a := by
@@ -6047,6 +13363,1500 @@ theorem LR.TyDefEq.lift {m : WShape n} (le : n ≤ n') (hmt : WShape.HasType m .
   simp [WShape.type] at this
   exact (LR.lift_succ_aux.1 this).trans ih
 
+/-- The canonical stratified logical relation realizes itself at every
+higher level. -/
+def LogRel.LiftEquiv.canonical (le : n ≤ n') :
+    LogRel.LiftEquiv (LR Γ : LogRel Γ n) (LR Γ : LogRel Γ n') le where
+  ty := by
+    intro A B a ha
+    exact LR.TyDefEq.lift le ha
+  term := by
+    intro M N A m a hma
+    exact LR.DefEq.lift le hma
+
+/-- Canonical cross-level transport for synchronized rectangles. -/
+theorem LR.DefEqRect.lift
+    {m a : WShape n} (le : n ≤ n') (hma : m.HasType a) :
+    LogRel.DefEqRect (LR Γ : LogRel Γ n') M₁ M₂ N₁ N₂ A
+        (m.lift n') (a.lift n') ↔
+      LogRel.DefEqRect (LR Γ : LogRel Γ n) M₁ M₂ N₁ N₂ A m a :=
+  (LogRel.LiftEquiv.canonical (Γ := Γ) le).rect hma
+
+/-- Build an observable constructor relation from exact related application
+spines and a semantic constructor bound at a level at least as large as the
+spine's.  Semantic arguments are newest-first, so the constructor's field
+list is their reverse. -/
+theorem LRS.CtorDefEq.of_exact_ctor_spines_of_le
+    {n k : Nat} {c : Name} {ls ls' : List SLevel}
+    {rargs : List (WShape n)} {xs ys : List SExpr}
+    {CHead CHead' A A' : SExpr}
+    (hargs : CtorArgsDefEq (LR Γ) xs ys rargs)
+    (haligned : CtorSpineDefEq (LR Γ) CHead xs ys rargs A)
+    (hmirror : CtorSpineDefEq (LR Γ) CHead' ys xs rargs A')
+    (hcl : Params.classify c = some (.ctor rargs.length))
+    (hlevels : ls = ls')
+    (hhead : IsDefEq Γ (.const c ls) (.const c ls) CHead)
+    (hhead' : IsDefEq Γ (.const c ls') (.const c ls') CHead')
+    (hspine : SExpr.SpineWF Γ CHead xs.reverse A)
+    (hspine' : SExpr.SpineWF Γ CHead' ys.reverse A')
+    (hn : n ≤ k)
+    {m : WShape (k + 1)}
+    (hle : m.T ≤ (WShape.ctor' c rargs.reverse).T) :
+    CtorDefEq Γ (LR Γ)
+      (xs.foldr (fun a f => f.app a) (.const c ls))
+      (ys.foldr (fun a f => f.app a) (.const c ls')) m := by
+  have hargs' : CtorArgsDefEq (LR Γ) xs ys (rargs.map (.lift k)) :=
+    hargs.lift hn (fun hmt => LR.TyDefEq.lift hn hmt)
+      (fun hma => LR.DefEq.lift hn hma)
+  have haligned' : CtorSpineDefEq (LR Γ) CHead xs ys
+      (rargs.map (.lift k)) A :=
+    haligned.lift hn (fun hmt => LR.TyDefEq.lift hn hmt)
+      (fun hma => LR.DefEq.lift hn hma)
+  have hmirror' : CtorSpineDefEq (LR Γ) CHead' ys xs
+      (rargs.map (.lift k)) A' :=
+    hmirror.lift hn (fun hmt => LR.TyDefEq.lift hn hmt)
+      (fun hma => LR.DefEq.lift hn hma)
+  have hwf : IsStruct c → WShape.ListNonZero ((rargs.map (.lift k)).reverse) := by
+    intro hs
+    simp [IsStruct, hcl] at hs
+  have hexact : CtorDefEq Γ (LR Γ)
+      (xs.foldr (fun a f => f.app a) (.const c ls))
+      (ys.foldr (fun a f => f.app a) (.const c ls'))
+      (.ctor c (rargs.map (.lift k)).reverse hwf) := by
+    exact .exact (hargs.lengths.1.symm ▸ hcl)
+      hargs'.lengths.1 hargs'.lengths.2 hlevels .rfl .rfl
+      hhead hhead' hspine hspine' hargs' haligned' hmirror'
+  have hle' : m ≤
+      WShape.ctor c (rargs.map (.lift k)).reverse hwf := by
+    have hle' := (TShape.LE.def (Nat.le_refl (k + 1))
+      (Nat.succ_le_succ hn)).1 hle
+    rw [WShape.lift_ctor' hn, List.map_reverse] at hle'
+    simpa only [WShape.lift_self, WShape.ctor_eq_ctor'] using hle'
+  exact .mono hle' hexact
+
+/-- Build an observable constructor relation from exact related application
+spines at arbitrary shape levels.  The finite evidence is first lifted to a
+common level; the relation's transport closure records that construction. -/
+theorem LRS.CtorDefEq.of_exact_ctor_spines
+    {n k : Nat} {c : Name} {ls ls' : List SLevel}
+    {rargs : List (WShape n)} {xs ys : List SExpr}
+    {CHead CHead' A A' : SExpr}
+    (hargs : CtorArgsDefEq (LR Γ) xs ys rargs)
+    (haligned : CtorSpineDefEq (LR Γ) CHead xs ys rargs A)
+    (hmirror : CtorSpineDefEq (LR Γ) CHead' ys xs rargs A')
+    (hcl : Params.classify c = some (.ctor rargs.length))
+    (hlevels : ls = ls')
+    (hhead : IsDefEq Γ (.const c ls) (.const c ls) CHead)
+    (hhead' : IsDefEq Γ (.const c ls') (.const c ls') CHead')
+    (hspine : SExpr.SpineWF Γ CHead xs.reverse A)
+    (hspine' : SExpr.SpineWF Γ CHead' ys.reverse A')
+    {m : WShape (k + 1)}
+    (hle : m.T ≤ (WShape.ctor' c rargs.reverse).T) :
+    CtorDefEq Γ (LR Γ)
+      (xs.foldr (fun a f => f.app a) (.const c ls))
+      (ys.foldr (fun a f => f.app a) (.const c ls')) m := by
+  let K := max k n
+  have hk : k ≤ K := Nat.le_max_left ..
+  have hn : n ≤ K := Nat.le_max_right ..
+  have hle' : (m.lift (K + 1)).T ≤
+      (WShape.ctor' c rargs.reverse).T :=
+    (TShape.lift_eqv (a := m.T) (Nat.succ_le_succ hk)).1.trans hle
+  exact .unlift hk (fun hmt => LR.TyDefEq.lift hk hmt)
+    (fun hma => LR.DefEq.lift hk hma) <|
+    of_exact_ctor_spines_of_le hargs haligned hmirror hcl hlevels hhead hhead'
+      hspine hspine' hn hle'
+
+/-- A concrete capture realized in one explicitly supplied logical
+relation.  This is the transport-friendly form consumed by
+`CtorDefEq.fold`: constructor fields live in `IH`, while recursor captures
+live one level higher in `LRS IH`. -/
+def LRS.CaptureDefEqAt (IH : LogRel Γ n) (m : TShape)
+    (x y : SExpr) : Prop :=
+  ∃ (elemShape typeShape : WShape n) (typeExpr : SExpr),
+    m ≤ elemShape.T ∧ elemShape.HasType typeShape ∧
+    IH.TyDefEq typeExpr typeExpr typeShape ∧
+    Γ ⊢ x ≡ y : typeExpr ∧
+    IH.DefEq x y typeExpr elemShape typeShape
+
+/-- Data chosen from a capture proposition when downstream dependent
+indices must refer to its exact type expression and shapes. -/
+structure LRS.CaptureDefEqAt.Witness
+    (IH : LogRel Γ n) (m : TShape) (x y : SExpr) where
+  elemShape : WShape n
+  typeShape : WShape n
+  typeExpr : SExpr
+  shape : m ≤ elemShape.T
+  hasType : elemShape.HasType typeShape
+  typeRelated : IH.TyDefEq typeExpr typeExpr typeShape
+  defeq : Γ ⊢ x ≡ y : typeExpr
+  related : IH.DefEq x y typeExpr elemShape typeShape
+
+/-- Choose the evidence-rich representative of an existential capture.
+The logical proposition remains proof-irrelevant; only this local
+noncomputable projection exposes its dependent indices. -/
+noncomputable def LRS.CaptureDefEqAt.witness
+    (H : CaptureDefEqAt IH m x y) : CaptureDefEqAt.Witness IH m x y :=
+  Classical.choice (by
+    rcases H with ⟨elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩
+    exact ⟨⟨elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩⟩)
+
+/-- A capture witness whose SExpr type is fixed by the surrounding dependent
+application spine.  Unlike `CaptureDefEqAt`, this proposition cannot choose
+an unrelated existential type at a variable RHS leaf. -/
+def LRS.CaptureDefEqAligned (IH : LogRel Γ n) (m : TShape)
+    (x y typeExpr : SExpr) : Prop :=
+  ∃ (elemShape typeShape : WShape n),
+    m ≤ elemShape.T ∧ elemShape.HasType typeShape ∧
+    IH.TyDefEq typeExpr typeExpr typeShape ∧
+    Γ ⊢ x ≡ y : typeExpr ∧
+    IH.DefEq x y typeExpr elemShape typeShape
+
+/-- The non-existential payload of an aligned capture at explicitly chosen
+element and type shapes.  This is the layer predicate retained by an
+ordered typed telescope. -/
+def LRS.CaptureDefEqAligned.AtShapes
+    (IH : LogRel Γ n) (m : TShape) (x y typeExpr : SExpr)
+    (elemShape typeShape : WShape n) : Prop :=
+  m ≤ elemShape.T ∧ elemShape.HasType typeShape ∧
+    IH.TyDefEq typeExpr typeExpr typeShape ∧
+    Γ ⊢ x ≡ y : typeExpr ∧
+    IH.DefEq x y typeExpr elemShape typeShape
+
+/-- Evidence-rich representative of an aligned capture.  The ordered
+dependent telescope must reuse one and the same `elemShape`/`typeShape`
+pair for the semantic argument bound, the function-domain typing, and the
+logical application step; choosing those existentials independently would
+erase precisely that synchronization. -/
+structure LRS.CaptureDefEqAligned.Witness
+    (IH : LogRel Γ n) (m : TShape)
+    (x y typeExpr : SExpr) where
+  elemShape : WShape n
+  typeShape : WShape n
+  shape : m ≤ elemShape.T
+  hasType : elemShape.HasType typeShape
+  typeRelated : IH.TyDefEq typeExpr typeExpr typeShape
+  defeq : Γ ⊢ x ≡ y : typeExpr
+  related : IH.DefEq x y typeExpr elemShape typeShape
+
+/-- Select the synchronized representative of an aligned capture once.
+Downstream dependent indices may refer to its exact shapes without adding
+any semantic premise. -/
+noncomputable def LRS.CaptureDefEqAligned.witness
+    (H : LRS.CaptureDefEqAligned IH m x y typeExpr) :
+    LRS.CaptureDefEqAligned.Witness IH m x y typeExpr :=
+  Classical.choice (by
+    rcases H with ⟨elemShape, typeShape, hshape, htype,
+      hty, hxy, hrel⟩
+    exact ⟨⟨elemShape, typeShape, hshape, htype,
+      hty, hxy, hrel⟩⟩)
+
+/-- Forget the chosen representative back to the proof-irrelevant aligned
+capture proposition. -/
+theorem LRS.CaptureDefEqAligned.Witness.aligned
+    (H : LRS.CaptureDefEqAligned.Witness IH m x y typeExpr) :
+    LRS.CaptureDefEqAligned IH m x y typeExpr :=
+  ⟨H.elemShape, H.typeShape, H.shape, H.hasType,
+    H.typeRelated, H.defeq, H.related⟩
+
+/-- Expose all aligned-capture fields at the witness's exact shapes. -/
+theorem LRS.CaptureDefEqAligned.Witness.atShapes
+    (H : LRS.CaptureDefEqAligned.Witness IH m x y typeExpr) :
+    LRS.CaptureDefEqAligned.AtShapes IH m x y typeExpr
+      H.elemShape H.typeShape :=
+  ⟨H.shape, H.hasType, H.typeRelated, H.defeq, H.related⟩
+
+/-- Consume one literally aligned dependent-application layer.
+
+The function relation lives one canonical stratum above the capture
+relation.  Because `elemShape` and `typeShape` are the exact pair retained
+by the ordered telescope, the ordinary logical application rule applies
+without lowering, lifting, or reselecting either shape.  Conversion edges
+in a surrounding `PathSpineWF` are intentionally outside this lemma. -/
+theorem LRS.CaptureDefEqAligned.AtShapes.app
+    {m : TShape} {x y A B M N : SExpr}
+    {elemShape typeShape : WShape n}
+    {termFun typeFun : WShapeFun n} {hterm : termFun.NonZero}
+    (H : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+      m x y A elemShape typeShape)
+    (hfun : (LR Γ).DefEq M N (.forallE A B)
+      (.lam termFun hterm) (.forallE typeShape typeFun)) :
+    (LR Γ).DefEq (M.app x) (N.app y) (B.inst x)
+      (termFun.app elemShape) (typeFun.app elemShape) := by
+  exact LR.DefEq.app hfun H.2.1 H.2.2.2.1 H.2.2.2.2
+
+/-- Lift a literally chosen aligned capture without reselecting either of its
+shape indices.  This is the exact transport used by the ordered fixed-head
+producer when a semantic application layer, its recursive result, and its
+logical capture initially live at different finite levels. -/
+theorem LRS.CaptureDefEqAligned.AtShapes.lift
+    {m : TShape} {x y A : SExpr} {elemShape typeShape : WShape n}
+    (le : n ≤ n')
+    (H : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+      m x y A elemShape typeShape) :
+    LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+      m x y A (elemShape.lift n') (typeShape.lift n') := by
+  exact ⟨H.1.trans (TShape.lift_eqv le).2,
+    (WShape.HasType.lift le).2 H.2.1,
+    (LR.TyDefEq.lift le H.2.1.isType).2 H.2.2.1,
+    H.2.2.2.1,
+    (LR.DefEq.lift le H.2.1).2 H.2.2.2.2⟩
+
+/-- An aligned capture at an existential canonical shape level.
+
+Generated iota paths mix recursor arguments and constructor fields from
+adjacent logical strata, while a semantic `ShapeSpine` may expose either at
+yet another `TShape` level.  Keeping the level existential here permits the
+producer to choose one common *higher* level and use `AtShapes.lift`; no
+downward projection of a logical observation is admitted. -/
+def LRS.CaptureDefEqAligned.AtSomeLevel (Γ : List SExpr)
+    (m : TShape) (x y typeExpr : SExpr) : Prop :=
+  ∃ (n : Nat) (elemShape typeShape : WShape n),
+    LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+      m x y typeExpr elemShape typeShape
+
+/-- Package an ordinary aligned capture at its existing canonical level. -/
+theorem LRS.CaptureDefEqAligned.atSomeLevel
+    (H : LRS.CaptureDefEqAligned (LR Γ : LogRel Γ n)
+      m x y typeExpr) :
+    LRS.CaptureDefEqAligned.AtSomeLevel Γ m x y typeExpr := by
+  rcases H with ⟨elemShape, typeShape, hshape, htyped,
+    htype, hraw, hrel⟩
+  exact ⟨n, elemShape, typeShape,
+    hshape, htyped, htype, hraw, hrel⟩
+
+/-- The syntax-independent shape ladder for one fixed-head application
+spine.
+
+`cons` records exactly one canonical logical application layer.  `liftHead`
+is deliberately one-sided: it raises only the current head observation and
+leaves the already-built tail/output untouched.  Its consumer can erase the
+frame with `LR.DefEq.lift`; the constructor therefore supports application
+layers whose semantic shape, recursive lower head, and capture relation were
+born at different levels without ever projecting a high refinement down. -/
+inductive LR.FixedHeadShapeChain (Γ : List SExpr)
+    {p : Pattern} (mcap : p.Path → TShape)
+    (mx my captureType : p.Path → SExpr) :
+    ∀ (paths : List p.Path)
+      {headLevel : Nat}, WShape headLevel → WShape headLevel →
+      ∀ {outLevel : Nat}, WShape outLevel → WShape outLevel → Prop where
+  | nil {n : Nat} {out outTy : WShape n} :
+      LR.FixedHeadShapeChain Γ mcap mx my captureType
+        [] out outTy out outTy
+  | cons
+      {n : Nat} {path : p.Path} {paths : List p.Path}
+      {termFun typeFun : WShapeFun n} {hterm : termFun.NonZero}
+      {argCap tyDom : WShape n}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+        (mcap path) (mx path) (my path) (captureType path)
+        argCap tyDom)
+      (tail : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths (termFun.app argCap) (typeFun.app argCap) out outTy) :
+      LR.FixedHeadShapeChain Γ mcap mx my captureType
+        (path :: paths) (.lam termFun hterm) (.forallE tyDom typeFun)
+        out outTy
+  | liftHead
+      {n n' : Nat} {head headTy : WShape n}
+      {paths : List p.Path} {outLevel : Nat}
+      {out outTy : WShape outLevel}
+      (le : n ≤ n') (htyped : head.HasType headTy)
+      (tail : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths head headTy out outTy) :
+      LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths (head.lift n') (headTy.lift n') out outTy
+
+/-- Build the complete syntax-independent logical shape ladder below one
+non-bottom semantic RHS spine.
+
+The construction proceeds from the result back to the fixed head.  At each
+layer it raises the semantic function/argument, the recursively synthesized
+head, and the chosen aligned capture to a common maximum level.  The new
+singleton lambda/Pi pair is typed at that exact common capture and lies below
+the semantic function head.  The terminal `out`/`outTy` pair is never lifted,
+so the eventual logical fold still lands at the caller's exact observation. -/
+theorem LE_Interp.RHS.ShapeSpine.fixedHeadShapeChain
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (H : LE_Interp.RHS.ShapeSpine mcap head paths out.T)
+    (hcap : ∀ path, LRS.CaptureDefEqAligned.AtSomeLevel Γ
+      (mcap path) (mx path) (my path) (captureType path))
+    (hout : out.HasType outTy) (houtNonbot : ¬out.T ≤ TShape.bot) :
+    ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        ¬headElem.T ≤ TShape.bot ∧
+        LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths headElem headElemTy out outTy := by
+  generalize houtT : out.T = outT at H
+  induction H generalizing outLevel out outTy with
+  | @nil head0 =>
+    have houtLe : out.T ≤ head0 := by
+      rw [houtT]
+      exact TShape.LE.rfl
+    exact ⟨outLevel, out, outTy, houtLe, hout, houtNonbot,
+      LR.FixedHeadShapeChain.nil⟩
+  | @cons n f a m outT path paths harg happ hrest ih =>
+    obtain ⟨nextLevel, next, nextTy, hnext, hnextTy,
+      hnextNonbot, tail⟩ := ih hout houtNonbot houtT
+    obtain ⟨capLevel, argCap, tyDom, capture⟩ := hcap path
+    have hnextApp : next.T ≤ (f.app a).T := hnext.trans happ
+    cases f using WShape.casesOn' with
+    | bot => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | sort => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | forallE => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | ctor => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | indTy => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | @lam g hg =>
+      let k := max n (max nextLevel capLevel)
+      have hk : n ≤ k ∧ nextLevel ≤ k ∧ capLevel ≤ k := by
+        dsimp [k]
+        omega
+      let aK : WShape k := a.lift k
+      let argCapK : WShape k := argCap.lift k
+      let tyDomK : WShape k := tyDom.lift k
+      let nextK : WShape k := next.lift k
+      let nextTyK : WShape k := nextTy.lift k
+      let elemFun : WShapeFun k := .single argCapK nextK
+      let typeFun : WShapeFun k := .single argCapK nextTyK
+      have hargBound : a.T ≤ argCap.T := harg.trans capture.1
+      have hargK : aK ≤ argCapK := by
+        exact (TShape.LE.def hk.1 hk.2.2).1 hargBound
+      have hnextAppK : nextK ≤ (g.lift k).app argCapK := by
+        have hmono : ((WShape.lam g hg).app a).T ≤
+            ((WShape.lam (g.lift k)
+              (WShapeFun.NonZero.lift_iff hk.1 |>.2 hg)).app argCapK).T := by
+          apply TShape.app_mono
+          · have hLift := (TShape.lift_eqv
+              (a := (WShape.lam g hg).T)
+              (Nat.succ_le_succ hk.1)).2
+            rw [WShape.lift_lam hk.1] at hLift
+            exact hLift
+          · exact hargBound.trans (TShape.lift_eqv hk.2.2).2
+        have hT : next.T ≤ ((g.lift k).app argCapK).T := by
+          simpa [WShape.lam_eq_lam'] using hnextApp.trans hmono
+        have hTK := (TShape.LE.def hk.2.1 (Nat.le_refl k)).1 hT
+        simpa only [nextK, WShape.lift_self] using hTK
+      have hnextKTy : nextK.HasType nextTyK :=
+        (WShape.HasType.lift hk.2.1).2 hnextTy
+      have hnextKNonbot : ¬nextK.T ≤ TShape.bot := by
+        intro hbot
+        exact hnextNonbot <|
+          (TShape.lift_eqv hk.2.1).2.trans
+            (hbot.trans TShape.bot_eqv.1)
+      have helemNonzero : elemFun.NonZero := by
+        rw [WShapeFun.NonZero.iff]
+        refine ⟨(argCapK, nextK),
+          WShapeFun.mem_single.2 (.inl rfl), ?_⟩
+        intro hbot
+        exact hnextKNonbot <|
+          (WShape.LE.T hbot).trans TShape.bot_eqv.1
+      let headElem : WShape (k + 1) := .lam elemFun helemNonzero
+      let headElemTy : WShape (k + 1) := .forallE tyDomK typeFun
+      have hcaptureK : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+          (mcap path) (mx path) (my path) (captureType path)
+          argCapK tyDomK := by
+        exact capture.lift hk.2.2
+      have hheadTyped : headElem.HasType headElemTy := by
+        change (WShape.lam elemFun helemNonzero).HasType
+          (WShape.forallE tyDomK typeFun)
+        rw [WShape.lam_eq_lam']
+        apply WShape.HasType.lam
+        refine WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+        · refine WShape.HasTypePi.def.2
+            ⟨WShape.HasDom.single.2 (.inl hcaptureK.2.1), ?_⟩
+          intro x y hxy
+          obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ :=
+            WShapeFun.mem_single.1 hxy
+          · exact hnextKTy.isType
+          · exact .bot' .sort
+        · exact WShape.HasDom.single.2 (.inl hcaptureK.2.1)
+        · simp only [elemFun, typeFun, WShapeFun.single_app]
+          split <;> [exact hnextKTy; exact .bot' (.bot' .sort)]
+      have hheadLeK : headElem ≤ .lam' (g.lift k) := by
+        change WShape.lam elemFun helemNonzero ≤ .lam' (g.lift k)
+        rw [WShape.lam_eq_lam']
+        apply WShape.lam'_le_lam'.2
+        obtain ⟨x', hx', hmem⟩ := (g.lift k).app_eq argCapK
+        exact WShapeFun.single_le.2
+          ⟨x', _, hmem, hx', hnextAppK⟩
+      have hliftHead : (WShape.lam' (g.lift k)).T ≤
+          (WShape.lam g hg).T := by
+        have hLift := (TShape.lift_eqv
+          (a := (WShape.lam g hg).T)
+          (Nat.succ_le_succ hk.1)).1
+        rw [WShape.lift_lam hk.1, WShape.lam_eq_lam'] at hLift
+        exact hLift
+      have hheadLe : headElem.T ≤ (WShape.lam g hg).T :=
+        hheadLeK.T.trans hliftHead
+      have tailK : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths nextK nextTyK out outTy :=
+        LR.FixedHeadShapeChain.liftHead hk.2.1 hnextTy tail
+      have tailApp : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths (elemFun.app argCapK) (typeFun.app argCapK) out outTy := by
+        simpa only [elemFun, typeFun, WShapeFun.single_app,
+          WShape.LE.rfl, ↓reduceIte] using tailK
+      have chain : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          (path :: paths) headElem headElemTy out outTy := by
+        exact LR.FixedHeadShapeChain.cons hcaptureK tailApp
+      exact ⟨k + 1, headElem, headElemTy, hheadLe,
+        hheadTyped, by
+          intro hbot
+          have happBotSame : (headElem.app argCapK).T ≤
+              ((WShape.bot (n := k + 1)).app argCapK).T :=
+            TShape.app_mono
+              (hbot.trans (TShape.bot_eqv (n := k + 1)).2)
+              TShape.LE.rfl
+          rw [WShape.bot_app] at happBotSame
+          have happBot : (headElem.app argCapK).T ≤ TShape.bot :=
+            happBotSame.trans TShape.bot_eqv.1
+          apply hnextKNonbot
+          simpa only [headElem, WShape.lam_eq_lam', WShape.lam'_app,
+            elemFun, WShapeFun.single_app, WShape.LE.rfl, ↓reduceIte]
+            using happBot,
+        chain⟩
+
+/-- Fold an ordered typed telescope into the logical application chain for
+the *same* lower term/type endpoint.
+
+Unlike `ShapeSpine.fixedHeadShapeChain`, this theorem does not choose a fresh
+capture representative at each path occurrence.  Its `Captures` argument is
+indexed by the exact `argCap`/`tyDom` pair stored in every telescope layer,
+and the returned `headElemTy ≤ headTy` proof follows the very same recursive
+choices.  Consequently a registered-type witness may be lowered to the
+returned head type without losing the capture chain that will consume it.
+
+Stated for the monotone packed telescope.  The base is the only place the
+terminal index is read at all, and it is read twice: once for the caller's own
+`out.HasType outTy` (which `WithCapturesLE.nil` now records at the caller's
+observation) and once for the returned bound `headElemTy.T ≤ headTy` (which
+now goes through the base comparison instead of an index equality).  The cons
+layer is untouched, which is why the exact form below is a one-line
+corollary. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.fixedHeadShapeChain
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {outShape outTyShape : TShape}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+      (m2 := mcap)
+      (fun {n} path (elemShape typeShape : WShape n) =>
+        LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+          (mcap path) (mx path) (my path) (captureType path)
+          elemShape typeShape)
+      head paths outShape headTy outTyShape)
+    (houtShapeEq : out.T = outShape)
+    (houtTyShapeEq : outTy.T = outTyShape)
+    (houtNonbot : ¬out.T ≤ TShape.bot) :
+    ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        headElemTy.T ≤ headTy ∧ ¬headElem.T ≤ TShape.bot ∧
+        LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths headElem headElemTy out outTy := by
+  revert out outTy
+  revert outLevel
+  let Motive := fun (head : TShape) (paths : List p.Path)
+      (outShape headTy outTyShape : TShape)
+      (_ : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+        (m2 := mcap)
+        (fun {n} path (elemShape typeShape : WShape n) =>
+          LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+            (mcap path) (mx path) (my path) (captureType path)
+            elemShape typeShape)
+        head paths outShape headTy outTyShape) =>
+      ∀ (outLevel : Nat) (out outTy : WShape outLevel),
+        out.T = outShape → outTy.T = outTyShape →
+        (¬out.T ≤ TShape.bot) →
+        ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+          headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+            headElemTy.T ≤ headTy ∧ ¬headElem.T ≤ TShape.bot ∧
+            LR.FixedHeadShapeChain Γ mcap mx my captureType
+              paths headElem headElemTy out outTy
+  change Motive head paths outShape headTy outTyShape H
+  refine LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.rec
+    (motive := Motive) ?_ ?_ H
+  · intro head headTy terminalTy htyped hle
+    intro outLevel out outTy houtShapeEq houtTyShapeEq houtNonbot
+    have houtLe : out.T ≤ head := by
+      rw [houtShapeEq]
+      exact TShape.LE.rfl
+    have houtTyLe : outTy.T ≤ headTy := by
+      rw [houtTyShapeEq]
+      exact hle
+    have houtTyped : out.HasType outTy := by
+      apply WShape.HasType.T_iff.1
+      rw [houtShapeEq, houtTyShapeEq]
+      exact htyped
+    exact ⟨outLevel, out, outTy, houtLe, houtTyped, houtTyLe,
+      houtNonbot, LR.FixedHeadShapeChain.nil⟩
+  · intro n f a m outT path paths tyDom tyFun argCap outTyT
+      harg happ hargCap hcapDom capture tail ih
+    intro outLevel out outTy houtShapeEq houtTyShapeEq houtNonbot
+    obtain ⟨nextLevel, next, nextTy, hnext, hnextTy,
+      hnextTyLe, hnextNonbot, tailChain⟩ :=
+      ih outLevel out outTy houtShapeEq houtTyShapeEq houtNonbot
+    have hnextApp : next.T ≤ (f.app a).T := hnext.trans happ
+    cases f using WShape.casesOn' with
+    | bot => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | sort => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | forallE => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | ctor => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | indTy => exact (hnextNonbot (hnextApp.trans TShape.bot_eqv.1)).elim
+    | @lam g hg =>
+      let k := max n nextLevel
+      have hk : n ≤ k ∧ nextLevel ≤ k := by
+        dsimp [k]
+        omega
+      let aK : WShape k := a.lift k
+      let argCapK : WShape k := argCap.lift k
+      let tyDomK : WShape k := tyDom.lift k
+      let nextK : WShape k := next.lift k
+      let nextTyK : WShape k := nextTy.lift k
+      let elemFun : WShapeFun k := .single argCapK nextK
+      let typeFun : WShapeFun k := .single argCapK nextTyK
+      have hargCapK : aK ≤ argCapK :=
+        WShape.lift_mono hk.1 hargCap
+      have hnextAppK : nextK ≤ (g.lift k).app argCapK := by
+        have hnextApp' : next.T ≤ ((WShape.lam g hg).app a).T := by
+          simpa using hnextApp
+        have hmono : ((WShape.lam g hg).app a).T ≤
+            ((WShape.lam (g.lift k)
+              (WShapeFun.NonZero.lift_iff hk.1 |>.2 hg)).app argCapK).T := by
+          apply TShape.app_mono
+          · have hLift := (TShape.lift_eqv
+              (a := (WShape.lam g hg).T)
+              (Nat.succ_le_succ hk.1)).2
+            rw [WShape.lift_lam hk.1] at hLift
+            exact hLift
+          · exact hargCap.T.trans (TShape.lift_eqv hk.1).2
+        have hT : next.T ≤ ((g.lift k).app argCapK).T := by
+          simpa [WShape.lam_eq_lam'] using hnextApp'.trans hmono
+        have hTK := (TShape.LE.def hk.2 (Nat.le_refl k)).1 hT
+        simpa only [nextK, WShape.lift_self] using hTK
+      have hnextTyKLe : nextTyK ≤ (tyFun.lift k).app argCapK := by
+        have hTK := (TShape.LE.def
+          (a := nextTy.T) (b := (tyFun.app argCap).T)
+          hk.2 hk.1).1 hnextTyLe
+        simpa only [nextTyK, argCapK, WShape.lift_self,
+          WShapeFun.lift_app hk.1] using hTK
+      have hnextKTy : nextK.HasType nextTyK :=
+        (WShape.HasType.lift hk.2).2 hnextTy
+      have hnextKNonbot : ¬nextK.T ≤ TShape.bot := by
+        intro hbot
+        exact hnextNonbot <|
+          (TShape.lift_eqv hk.2).2.trans
+            (hbot.trans TShape.bot_eqv.1)
+      have helemNonzero : elemFun.NonZero := by
+        rw [WShapeFun.NonZero.iff]
+        refine ⟨(argCapK, nextK),
+          WShapeFun.mem_single.2 (.inl rfl), ?_⟩
+        intro hbot
+        exact hnextKNonbot <|
+          (WShape.LE.T hbot).trans TShape.bot_eqv.1
+      let headElem : WShape (k + 1) := .lam elemFun helemNonzero
+      let headElemTy : WShape (k + 1) := .forallE tyDomK typeFun
+      have hcaptureK : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+          (mcap path) (mx path) (my path) (captureType path)
+          argCapK tyDomK := by
+        exact capture.lift hk.1
+      have hheadTyped : headElem.HasType headElemTy := by
+        change (WShape.lam elemFun helemNonzero).HasType
+          (WShape.forallE tyDomK typeFun)
+        rw [WShape.lam_eq_lam']
+        apply WShape.HasType.lam
+        refine WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+        · refine WShape.HasTypePi.def.2
+            ⟨WShape.HasDom.single.2 (.inl hcaptureK.2.1), ?_⟩
+          intro x y hxy
+          obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ :=
+            WShapeFun.mem_single.1 hxy
+          · exact hnextKTy.isType
+          · exact .bot' .sort
+        · exact WShape.HasDom.single.2 (.inl hcaptureK.2.1)
+        · simp only [elemFun, typeFun, WShapeFun.single_app]
+          split <;> [exact hnextKTy; exact .bot' (.bot' .sort)]
+      have hheadLeK : headElem ≤ .lam' (g.lift k) := by
+        change WShape.lam elemFun helemNonzero ≤ .lam' (g.lift k)
+        rw [WShape.lam_eq_lam']
+        apply WShape.lam'_le_lam'.2
+        obtain ⟨x', hx', hmem⟩ := (g.lift k).app_eq argCapK
+        exact WShapeFun.single_le.2
+          ⟨x', _, hmem, hx', hnextAppK⟩
+      have hliftHead : (WShape.lam' (g.lift k)).T ≤
+          (WShape.lam g hg).T := by
+        have hLift := (TShape.lift_eqv
+          (a := (WShape.lam g hg).T)
+          (Nat.succ_le_succ hk.1)).1
+        rw [WShape.lift_lam hk.1, WShape.lam_eq_lam'] at hLift
+        exact hLift
+      have hheadLe : headElem.T ≤ (WShape.lam g hg).T :=
+        hheadLeK.T.trans hliftHead
+      have htypeFunLe : typeFun ≤ tyFun.lift k := by
+        obtain ⟨x', hx', hmem⟩ := (tyFun.lift k).app_eq argCapK
+        exact WShapeFun.single_le.2
+          ⟨x', _, hmem, hx', hnextTyKLe⟩
+      have hheadTyLeK : headElemTy ≤
+          .forallE tyDomK (tyFun.lift k) := by
+        exact WShape.forallE_le_forallE.2 ⟨.rfl, htypeFunLe⟩
+      have hliftHeadTy : (WShape.forallE tyDomK (tyFun.lift k)).T ≤
+          (WShape.forallE tyDom tyFun).T := by
+        have hLift := (TShape.lift_eqv
+          (a := (WShape.forallE tyDom tyFun).T)
+          (Nat.succ_le_succ hk.1)).1
+        rw [WShape.lift_forallE hk.1] at hLift
+        exact hLift
+      have hheadTyLe : headElemTy.T ≤
+          (WShape.forallE tyDom tyFun).T :=
+        hheadTyLeK.T.trans hliftHeadTy
+      have tailK : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths nextK nextTyK out outTy :=
+        LR.FixedHeadShapeChain.liftHead hk.2 hnextTy tailChain
+      have tailApp : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths (elemFun.app argCapK) (typeFun.app argCapK)
+            out outTy := by
+        simpa only [elemFun, typeFun, WShapeFun.single_app,
+          WShape.LE.rfl, ↓reduceIte] using tailK
+      have chain : LR.FixedHeadShapeChain Γ mcap mx my captureType
+          (path :: paths) headElem headElemTy out outTy := by
+        exact LR.FixedHeadShapeChain.cons hcaptureK tailApp
+      exact ⟨k + 1, headElem, headElemTy, hheadLe,
+        hheadTyped, hheadTyLe, by
+          intro hbot
+          have happBotSame : (headElem.app argCapK).T ≤
+              ((WShape.bot (n := k + 1)).app argCapK).T :=
+            TShape.app_mono
+              (hbot.trans (TShape.bot_eqv (n := k + 1)).2)
+              TShape.LE.rfl
+          rw [WShape.bot_app] at happBotSame
+          have happBot : (headElem.app argCapK).T ≤ TShape.bot :=
+            happBotSame.trans TShape.bot_eqv.1
+          apply hnextKNonbot
+          simpa only [headElem, WShape.lam_eq_lam', WShape.lam'_app,
+            elemFun, WShapeFun.single_app, WShape.LE.rfl, ↓reduceIte]
+            using happBot,
+        chain⟩
+
+/-- The exact packed telescope folds through the monotone one.  Statement
+unchanged; every existing consumer applies verbatim. -/
+theorem LE_Interp.RHS.ShapeSpine.TypedTelescope.fixedHeadShapeChain
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {outShape outTyShape : TShape}
+    (H : LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+      (m2 := mcap)
+      (fun {n} path (elemShape typeShape : WShape n) =>
+        LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+          (mcap path) (mx path) (my path) (captureType path)
+          elemShape typeShape)
+      head paths outShape headTy outTyShape)
+    (houtShapeEq : out.T = outShape)
+    (houtTyShapeEq : outTy.T = outTyShape)
+    (houtNonbot : ¬out.T ≤ TShape.bot) :
+    ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        headElemTy.T ≤ headTy ∧ ¬headElem.T ≤ TShape.bot ∧
+        LR.FixedHeadShapeChain Γ mcap mx my captureType
+          paths headElem headElemTy out outTy :=
+  H.toLE.fixedHeadShapeChain houtShapeEq houtTyShapeEq houtNonbot
+
+/-- A canonical logical application chain over one ordered capture list.
+
+Every constructor records the exact function/type observations used by one
+`LR.DefEq.app` step and recurses at the predecessor shape level selected by
+that application.  The terminal constructor pins both shapes and the result
+syntax literally.  Thus this structure contains no conversion or endpoint
+coercion; those belong to the separate bridge from `PathSpineWF` and the
+semantic typed telescope. -/
+inductive LR.FixedHeadChain (Γ : List SExpr)
+    {p : Pattern} (mcap : p.Path → TShape)
+    (mx my captureType : p.Path → SExpr) :
+    ∀ (paths : List p.Path) (headType resultType : SExpr)
+      {headLevel : Nat}, WShape headLevel → WShape headLevel →
+      ∀ {outLevel : Nat}, WShape outLevel → WShape outLevel → Prop where
+  | nil {A : SExpr} {n : Nat} {out outTy : WShape n} :
+      LR.FixedHeadChain Γ mcap mx my captureType
+        [] A A out outTy out outTy
+  | cons
+      {n : Nat} {path : p.Path} {paths : List p.Path}
+      {body resultType : SExpr}
+      {termFun typeFun : WShapeFun n} {hterm : termFun.NonZero}
+      {argCap tyDom : WShape n}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+        (mcap path) (mx path) (my path) (captureType path)
+        argCap tyDom)
+      (tail : LR.FixedHeadChain Γ mcap mx my captureType
+        paths (body.inst (mx path)) resultType
+        (termFun.app argCap) (typeFun.app argCap) out outTy) :
+      LR.FixedHeadChain Γ mcap mx my captureType
+        (path :: paths) (.forallE (captureType path) body) resultType
+        (.lam termFun hterm) (.forallE tyDom typeFun) out outTy
+
+/-- Fold a canonical fixed-head chain by repeated dependent logical
+application.  Shape levels decrease exactly where `LR.DefEq.app` decreases
+them; no lift/unlift frame appears in this consumer. -/
+theorem LR.FixedHeadChain.apply
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {headType resultType : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (H : LR.FixedHeadChain Γ mcap mx my captureType
+      paths headType resultType head headTy out outTy)
+    {M N : SExpr}
+    (hhead : (LR Γ).DefEq M N headType head headTy) :
+    (LR Γ).DefEq
+      (paths.foldl (fun f path => f.app (mx path)) M)
+      (paths.foldl (fun f path => f.app (my path)) N)
+      resultType out outTy := by
+  induction H generalizing M N with
+  | nil => exact hhead
+  | cons capture tail ih =>
+    simp only [List.foldl_cons]
+    exact ih (capture.app hhead)
+
+/-- A conversion-safe logical application chain over one path-indexed
+capture spine.
+
+Every application node stores the weak-head Pi telescope exposed for the
+*current declared type*.  Thus a raw `PathSpineWF.conv` is normalized by the
+producer before it reaches this certificate; the consumer never promotes
+that raw equality to a same-level semantic equality.  The only semantic
+conversion fields are the exact lower-level domain and terminal alignments
+needed by dependent application.  `liftHead` records canonical upward shape
+alignment without changing either syntax endpoint or the exact output. -/
+inductive LR.FixedHeadExposedChain (Γ : List SExpr)
+    {p : Pattern} (mcap : p.Path → TShape)
+    (mx my captureType : p.Path → SExpr) :
+    ∀ (paths : List p.Path) (headType resultType : SExpr)
+      {headLevel : Nat}, WShape headLevel → WShape headLevel →
+      ∀ {outLevel : Nat}, WShape outLevel → WShape outLevel → Prop where
+  | nil {A : SExpr} {n : Nat} {out outTy : WShape n} :
+      LR.FixedHeadExposedChain Γ mcap mx my captureType
+        [] A A out outTy out outTy
+  | cons
+      {n : Nat} {path : p.Path} {paths : List p.Path}
+      {headType A₁ A₂ resultType : SExpr} {u : SLevel}
+      {termFun typeFun : WShapeFun n} {hterm : termFun.NonZero}
+      {argCap tyDom : WShape n}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      (headRed : WHRedS Γ headType (.forallE A₁ A₂))
+      (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+        (mcap path) (mx path) (my path) (captureType path)
+        argCap tyDom)
+      (domainRaw : TypeDefEqPath Γ (captureType path) A₁ u)
+      (domainRel : (LR Γ).TyDefEq (captureType path) A₁ tyDom)
+      (tail : LR.FixedHeadExposedChain Γ mcap mx my captureType
+        paths (A₂.inst (mx path)) resultType
+        (termFun.app argCap) (typeFun.app argCap) out outTy) :
+      LR.FixedHeadExposedChain Γ mcap mx my captureType
+        (path :: paths) headType resultType
+        (.lam termFun hterm) (.forallE tyDom typeFun) out outTy
+  | liftHead
+      {n n' : Nat} {head headTy : WShape n}
+      {paths : List p.Path} {headType resultType : SExpr}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      (le : n ≤ n') (htyped : head.HasType headTy)
+      (tail : LR.FixedHeadExposedChain Γ mcap mx my captureType
+        paths headType resultType head headTy out outTy) :
+      LR.FixedHeadExposedChain Γ mcap mx my captureType
+        paths headType resultType
+        (head.lift n') (headTy.lift n') out outTy
+  | ret
+      {paths : List p.Path} {headType resultType resultType' : SExpr}
+      {u : SLevel}
+      {headLevel : Nat} {head headTy : WShape headLevel}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      (tail : LR.FixedHeadExposedChain Γ mcap mx my captureType
+        paths headType resultType head headTy out outTy)
+      (resultRaw : TypeDefEqPath Γ resultType resultType' u)
+      (resultRel : (LR Γ).TyDefEq resultType resultType' outTy) :
+      LR.FixedHeadExposedChain Γ mcap mx my captureType
+        paths headType resultType' head headTy out outTy
+
+/-- Change the declared type at the fixed head after an exact semantic type
+alignment has already been constructed.
+
+This is the consumer-side operation needed for `PathSpineWF.conv`.  It does
+not derive a logical relation from the raw equality: the producer must pass
+that relation explicitly (and, in the adequacy construction, obtains it only
+from the strictly-smaller-depth provenance restart).  At a nonempty spine the
+stored Pi observation exposes both sides of the supplied type relation;
+weak-head determinism identifies its right observation with the telescope
+already retained by the chain. -/
+theorem LR.FixedHeadExposedChain.rehead
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {headType headType' resultType : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (H : LR.FixedHeadExposedChain Γ mcap mx my captureType
+      paths headType' resultType head headTy out outTy)
+    {u : SLevel}
+    (hraw : TypeDefEqPath Γ headType headType' u)
+    (hrel : (LR Γ).TyDefEq headType headType' headTy) :
+    LR.FixedHeadExposedChain Γ mcap mx my captureType
+      paths headType resultType head headTy out outTy := by
+  induction H generalizing headType u with
+  | nil =>
+    exact LR.FixedHeadExposedChain.ret
+      LR.FixedHeadExposedChain.nil hraw hrel
+  | @cons n path paths headType' A₁ A₂ resultType v termFun typeFun
+      hterm argCap tyDom outLevel out outTy headRed capture domainRaw
+      domainRel tail ih =>
+    rw [LR_succ] at hrel
+    obtain ⟨B₁, F₁, B₂, F₂, _u₁, _u₂,
+      hred₁, hred₂, hdom, hcod, hvalDom, hpi⟩ := hrel
+    have hPiEq : SExpr.forallE B₂ F₂ = .forallE A₁ A₂ :=
+      hred₂.determ .forallE headRed .forallE
+    cases hPiEq
+    obtain ⟨_, hdomSymm⟩ := hdom.symm
+    let domainRaw' : TypeDefEqPath Γ (captureType path) B₁ v :=
+      .trans domainRaw hdomSymm
+    let domainRel' : (LR Γ).TyDefEq
+        (captureType path) B₁ tyDom :=
+      (LR Γ).trans_ty domainRel ((LR Γ).symm_ty hvalDom)
+    have hargRaw : IsDefEq Γ (mx path) (my path) B₁ :=
+      domainRaw'.defeqDF capture.2.2.2.1
+    have hargRel : (LR Γ).DefEq
+        (mx path) (my path) B₁ argCap tyDom :=
+      (LR Γ).conv domainRel' capture.2.2.2.2
+    have hcodInst : TypeDefEqPath Γ
+        (F₁.inst (mx path)) (A₂.inst (mx path)) _u₂ := by
+      simpa only [SExpr.inst] using hcod.subst
+        (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar hargRaw.hasType.1)
+    have hcodRel : (LR Γ).TyDefEq
+        (F₁.inst (mx path)) (A₂.inst (mx path))
+        (typeFun.app argCap) :=
+      hpi.2 capture.2.1 hargRaw.hasType.1 ((LR Γ).left hargRel)
+    exact LR.FixedHeadExposedChain.cons hred₁ capture
+      domainRaw' domainRel' (ih hcodInst hcodRel)
+  | liftHead le htyped tail ih =>
+    exact LR.FixedHeadExposedChain.liftHead le htyped <|
+      ih hraw ((LR.TyDefEq.lift le htyped.isType).1 hrel)
+  | ret tail resultRaw resultRel ih =>
+    exact LR.FixedHeadExposedChain.ret
+      (ih hraw hrel) resultRaw resultRel
+
+/-- The semantic alignments for one concrete path-indexed typing spine.
+
+This certificate zips a syntax-independent `FixedHeadShapeChain` with the
+*actual* `PathSpineWF` derivation used by the generated RHS.  Only conversion
+edges present in that derivation receive semantic payloads.  In particular,
+there is no callback that can turn an arbitrary raw equality into a logical
+type equality; the adequacy producer must construct each `headRel`,
+`domainRel`, and `resultRel` at its reviewed smaller-depth boundary. -/
+inductive LR.FixedHeadPathSemantics (Γ : List SExpr)
+    {p : Pattern} (mcap : p.Path → TShape)
+    (mx my captureType : p.Path → SExpr) :
+    ∀ {paths : List p.Path} {headType resultType : SExpr}
+      {headLevel : Nat} {head headTy : WShape headLevel}
+      {outLevel : Nat} {out outTy : WShape outLevel},
+      LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths head headTy out outTy →
+      SExpr.PathSpineWF Γ mx captureType
+        headType paths resultType → Prop where
+  | nil {A : SExpr} {n : Nat} {out outTy : WShape n} :
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        (LR.FixedHeadShapeChain.nil (out := out) (outTy := outTy))
+        (SExpr.PathSpineWF.nil (A := A))
+  | cons
+      {n : Nat} {path : p.Path} {paths : List p.Path}
+      {A₁ A₂ resultType : SExpr} {u : SLevel}
+      {termFun typeFun : WShapeFun n} {hterm : termFun.NonZero}
+      {argCap tyDom : WShape n}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      {capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ)
+        (mcap path) (mx path) (my path) (captureType path)
+        argCap tyDom}
+      {tailShape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths (termFun.app argCap) (typeFun.app argCap) out outTy}
+      {domainRaw : IsDefEq Γ (captureType path) A₁ (.sort u)}
+      {tailRaw : SExpr.PathSpineWF Γ mx captureType
+        (A₂.inst (mx path)) paths resultType}
+      (domainRel : (LR Γ).TyDefEq (captureType path) A₁ tyDom)
+      (tail : LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        tailShape tailRaw) :
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        (LR.FixedHeadShapeChain.cons (hterm := hterm) capture tailShape)
+        (SExpr.PathSpineWF.cons domainRaw tailRaw)
+  | liftHead
+      {n n' : Nat} {head headTy : WShape n}
+      {paths : List p.Path} {headType resultType : SExpr}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      {le : n ≤ n'} {htyped : head.HasType headTy}
+      {tailShape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths head headTy out outTy}
+      {raw : SExpr.PathSpineWF Γ mx captureType
+        headType paths resultType}
+      (tail : LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        tailShape raw) :
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        (LR.FixedHeadShapeChain.liftHead le htyped tailShape) raw
+  | conv
+      {paths : List p.Path} {headType headType' resultType : SExpr}
+      {u : SLevel}
+      {headLevel : Nat} {head headTy : WShape headLevel}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      {shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths head headTy out outTy}
+      {headRaw : IsDefEq Γ headType headType' (.sort u)}
+      {tailRaw : SExpr.PathSpineWF Γ mx captureType
+        headType' paths resultType}
+      (headRel : (LR Γ).TyDefEq headType headType' headTy)
+      (tail : LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        shape tailRaw) :
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType shape
+        (SExpr.PathSpineWF.conv headRaw tailRaw)
+  | ret
+      {paths : List p.Path} {headType resultType resultType' : SExpr}
+      {u : SLevel}
+      {headLevel : Nat} {head headTy : WShape headLevel}
+      {outLevel : Nat} {out outTy : WShape outLevel}
+      {shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths head headTy out outTy}
+      {tailRaw : SExpr.PathSpineWF Γ mx captureType
+        headType paths resultType}
+      {resultRaw : IsDefEq Γ resultType resultType' (.sort u)}
+      (resultRel : (LR Γ).TyDefEq resultType resultType' outTy)
+      (tail : LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        shape tailRaw) :
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType shape
+        (SExpr.PathSpineWF.ret tailRaw resultRaw)
+
+/-- Zip an empty concrete spine with a shape chain containing only terminal
+and head-lift frames.  The explicit path-index equality keeps the structural
+recursor general enough to recognize each `liftHead` tail as a subderivation. -/
+theorem LR.FixedHeadShapeChain.pathSemanticsNil
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {shapePaths : List p.Path} {A : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+      shapePaths head headTy out outTy)
+    (hpaths : shapePaths = []) :
+    LR.FixedHeadPathSemantics Γ mcap mx my captureType
+      (hpaths ▸ shape) (SExpr.PathSpineWF.nil (A := A)) := by
+  induction shape with
+  | nil =>
+    cases hpaths
+    exact LR.FixedHeadPathSemantics.nil
+  | cons capture tail =>
+    cases hpaths
+  | liftHead le htyped tail ih =>
+    cases hpaths
+    exact LR.FixedHeadPathSemantics.liftHead
+      (le := le) (htyped := htyped)
+      (raw := SExpr.PathSpineWF.nil (A := A))
+      (ih rfl)
+
+/-- Zip one concrete application edge after stripping any leading head-lift
+frames from the syntax-independent shape chain. -/
+theorem LR.FixedHeadShapeChain.pathSemanticsCons
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {shapePaths : List p.Path}
+    {path : p.Path} {paths : List p.Path}
+    {A₁ A₂ resultType : SExpr} {u : SLevel}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+      shapePaths head headTy out outTy)
+    (hpaths : shapePaths = path :: paths)
+    (domainRaw : IsDefEq Γ (captureType path) A₁ (.sort u))
+    (tailRaw : SExpr.PathSpineWF Γ mx captureType
+      (A₂.inst (mx path)) paths resultType)
+    (headRel : (LR Γ).TyDefEq
+      (.forallE A₁ A₂) (.forallE A₁ A₂) headTy)
+    (convert : ∀ {n : Nat} {A B : SExpr} {v : SLevel}
+        {a : WShape n},
+      IsDefEq Γ A B (.sort v) →
+      (LR Γ).TyDefEq A A a →
+      (LR Γ).TyDefEq A B a)
+    (tailSemantics : ∀ {tailLevel : Nat}
+        {tailHead tailHeadTy : WShape tailLevel},
+      (tailShape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+        paths tailHead tailHeadTy out outTy) →
+      (LR Γ).TyDefEq
+        (A₂.inst (mx path)) (A₂.inst (mx path)) tailHeadTy →
+      LR.FixedHeadPathSemantics Γ mcap mx my captureType
+        tailShape tailRaw) :
+    LR.FixedHeadPathSemantics Γ mcap mx my captureType
+      (hpaths ▸ shape) (SExpr.PathSpineWF.cons domainRaw tailRaw) := by
+  induction shape with
+  | nil =>
+    cases hpaths
+  | @cons n path₀ paths₀ termFun typeFun hterm argCap tyDom
+      outLevel out outTy capture tail =>
+    cases hpaths
+    rw [LR_succ] at headRel
+    obtain ⟨B₁, F₁, B₂, F₂, _u₁, _u₂,
+      hred₁, hred₂, _hdom, _hcod, _domainSelf, hpi⟩ := headRel
+    have hPi₁ : SExpr.forallE B₁ F₁ = .forallE A₁ A₂ :=
+      hred₁.determ .forallE .rfl .forallE
+    have hPi₂ : SExpr.forallE B₂ F₂ = .forallE A₁ A₂ :=
+      hred₂.determ .forallE .rfl .forallE
+    cases hPi₁
+    cases hPi₂
+    have domainRel : (LR Γ).TyDefEq
+        (captureType path) A₁ tyDom :=
+      convert domainRaw capture.2.2.1
+    have argRaw : IsDefEq Γ (mx path) (my path) A₁ :=
+      domainRaw.defeqDF capture.2.2.2.1
+    have argRel : (LR Γ).DefEq
+        (mx path) (my path) A₁ argCap tyDom :=
+      (LR Γ).conv domainRel capture.2.2.2.2
+    have tailHeadRel : (LR Γ).TyDefEq
+        (A₂.inst (mx path)) (A₂.inst (mx path))
+        (typeFun.app argCap) :=
+      hpi.2 capture.2.1 argRaw.hasType.1 ((LR Γ).left argRel)
+    exact LR.FixedHeadPathSemantics.cons
+      (u := u) (capture := capture)
+      (domainRaw := domainRaw) (tailRaw := tailRaw)
+      domainRel (tailSemantics tail tailHeadRel)
+  | liftHead le htyped tail ih =>
+    cases hpaths
+    exact LR.FixedHeadPathSemantics.liftHead
+      (le := le) (htyped := htyped)
+      (raw := SExpr.PathSpineWF.cons domainRaw tailRaw) <|
+      ih rfl ((LR.TyDefEq.lift le htyped.isType).1 headRel)
+        tailSemantics
+
+/-- Add the semantic payloads to one concrete path-indexed typing spine.
+
+The conversion callback is invoked only for an equality edge occurring in
+the supplied `PathSpineWF`, and only after the source endpoint is already
+known to be a valid logical type at the exact shape threaded by the fixed
+head chain.  Its destination self-validity is recovered from the returned
+heterogeneous edge.  This is the structural half of the ordered producer;
+the adequacy construction supplies `convert` from its strictly-smaller-depth
+provenance restart. -/
+theorem LR.FixedHeadShapeChain.pathSemantics
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {headType resultType : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+      paths head headTy out outTy)
+    (raw : SExpr.PathSpineWF Γ mx captureType
+      headType paths resultType)
+    (headRel : (LR Γ).TyDefEq headType headType headTy)
+    (resultRel : (LR Γ).TyDefEq resultType resultType outTy)
+    (convert : ∀ {n : Nat} {A B : SExpr} {u : SLevel}
+        {a : WShape n},
+      IsDefEq Γ A B (.sort u) →
+      (LR Γ).TyDefEq A A a →
+      (LR Γ).TyDefEq A B a) :
+    LR.FixedHeadPathSemantics Γ mcap mx my captureType shape raw := by
+  induction raw generalizing headLevel head headTy with
+  | @nil A =>
+    simpa only using shape.pathSemanticsNil (A := A) rfl
+  | @cons path A₁ u paths resultType A₂ domainRaw tailRaw ih =>
+    exact shape.pathSemanticsCons rfl domainRaw tailRaw headRel convert
+      (fun tail tailHeadRel => ih tail tailHeadRel resultRel)
+  | @conv headType headType' u paths resultType headRaw tailRaw ih =>
+    have headCross : (LR Γ).TyDefEq headType headType' headTy :=
+      convert headRaw headRel
+    have tailHeadRel : (LR Γ).TyDefEq headType' headType' headTy :=
+      (LR Γ).left_ty ((LR Γ).symm_ty headCross)
+    exact LR.FixedHeadPathSemantics.conv
+      (u := u) (headRaw := headRaw) (tailRaw := tailRaw) headCross
+      (ih shape tailHeadRel resultRel)
+  | @ret headType paths resultType resultType' u tailRaw resultRaw ih =>
+    have resultCrossRev : (LR Γ).TyDefEq
+        resultType' resultType outTy :=
+      convert resultRaw.symm resultRel
+    have tailResultRel : (LR Γ).TyDefEq
+        resultType resultType outTy :=
+      (LR Γ).left_ty ((LR Γ).symm_ty resultCrossRev)
+    exact LR.FixedHeadPathSemantics.ret
+      (u := u) (tailRaw := tailRaw) (resultRaw := resultRaw)
+      ((LR Γ).symm_ty resultCrossRev)
+      (ih shape headRel tailResultRel)
+
+/-- Forget the producer provenance and obtain the canonical exposed-head
+application certificate consumed by the logical fold. -/
+theorem LR.FixedHeadPathSemantics.exposed
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {headType resultType : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {shape : LR.FixedHeadShapeChain Γ mcap mx my captureType
+      paths head headTy out outTy}
+    {raw : SExpr.PathSpineWF Γ mx captureType
+      headType paths resultType}
+    (H : LR.FixedHeadPathSemantics Γ mcap mx my captureType shape raw) :
+    LR.FixedHeadExposedChain Γ mcap mx my captureType
+      paths headType resultType head headTy out outTy := by
+  induction H with
+  | nil => exact LR.FixedHeadExposedChain.nil
+  | @cons n path paths A₁ A₂ resultType u termFun typeFun hterm
+      argCap tyDom outLevel out outTy capture tailShape domainRaw tailRaw
+      domainRel tail ih =>
+    exact LR.FixedHeadExposedChain.cons .rfl capture
+      (.single domainRaw) domainRel ih
+  | @liftHead n n' head headTy paths headType resultType outLevel out outTy
+      le htyped tailShape raw tail ih =>
+    exact LR.FixedHeadExposedChain.liftHead le htyped ih
+  | @conv paths headType headType' resultType u headLevel head headTy
+      outLevel out outTy shape headRaw tailRaw headRel tail ih =>
+    exact ih.rehead (.single headRaw) headRel
+  | @ret paths headType resultType resultType' u headLevel head headTy
+      outLevel out outTy shape tailRaw resultRaw resultRel tail ih =>
+    exact LR.FixedHeadExposedChain.ret ih (.single resultRaw) resultRel
+
+/-- Fold the exposed-head fixed-head certificate.
+
+At an application node `app_exposed` independently reveals the Pi telescope
+stored by the function relation.  Weak-head determinism identifies it with
+the producer's retained telescope, after which the exact domain conversion
+retypes the aligned capture.  In particular there is no semantic analogue of
+`PathSpineWF.conv` in this induction. -/
+theorem LR.FixedHeadExposedChain.apply
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {headType resultType : SExpr}
+    {headLevel : Nat} {head headTy : WShape headLevel}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    (H : LR.FixedHeadExposedChain Γ mcap mx my captureType
+      paths headType resultType head headTy out outTy)
+    {M N : SExpr}
+    (hhead : (LR Γ).DefEq M N headType head headTy) :
+    (LR Γ).DefEq
+      (paths.foldl (fun f path => f.app (mx path)) M)
+      (paths.foldl (fun f path => f.app (my path)) N)
+      resultType out outTy := by
+  induction H generalizing M N with
+  | nil => exact hhead
+  | @cons n path paths headType A₁ A₂ resultType u termFun typeFun
+      hterm argCap tyDom outLevel out outTy headRed capture domainRaw
+      domainRel tail ih =>
+    simp only [List.foldl_cons]
+    rw [LR_succ] at hhead
+    obtain ⟨B, F, _u, _v, hred, _hB, _hValB, _hF, _hPi, happ⟩ :=
+      LRS.DefEq.app_exposed hhead capture.2.1
+    have hPiEq : SExpr.forallE B F = .forallE A₁ A₂ :=
+      hred.determ .forallE headRed .forallE
+    cases hPiEq
+    apply ih
+    exact happ
+      (domainRaw.defeqDF capture.2.2.2.1)
+      ((LR Γ).conv domainRel capture.2.2.2.2)
+  | liftHead le htyped tail ih =>
+    exact ih ((LR.DefEq.lift le htyped).1 hhead)
+  | ret tail _resultRaw resultRel ih =>
+    exact (LR Γ).conv resultRel (ih hhead)
+
+/-- The chosen type of an existential capture gives its aligned form. -/
+theorem LRS.CaptureDefEqAt.Witness.aligned
+    (H : CaptureDefEqAt.Witness IH m x y) :
+    CaptureDefEqAligned IH m x y H.typeExpr :=
+  ⟨H.elemShape, H.typeShape, H.shape, H.hasType,
+    H.typeRelated, H.defeq, H.related⟩
+
+/-- Forget a fixed capture type back to the existential packaging. -/
+theorem LRS.CaptureDefEqAligned.toCapture
+    (H : CaptureDefEqAligned IH m x y typeExpr) :
+    CaptureDefEqAt IH m x y := by
+  rcases H with ⟨elemShape, typeShape, hshape, htype, hty, hxy, hrel⟩
+  exact ⟨elemShape, typeShape, typeExpr,
+    hshape, htype, hty, hxy, hrel⟩
+
+theorem LRS.CaptureDefEqAligned.mono (hle : m ≤ m') :
+    CaptureDefEqAligned IH m' x y typeExpr →
+      CaptureDefEqAligned IH m x y typeExpr := by
+  rintro ⟨elemShape, typeShape, hshape, htype, hty, hxy, hrel⟩
+  exact ⟨elemShape, typeShape, hle.trans hshape,
+    htype, hty, hxy, hrel⟩
+
+theorem LRS.CaptureDefEqAligned.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+    CaptureDefEqAligned IH cap x y typeExpr →
+      CaptureDefEqAligned IH' cap x y typeExpr := by
+  rintro ⟨elemShape, typeShape, hshape, htype, hty, hxy, hrel⟩
+  exact ⟨elemShape.lift n', typeShape.lift n',
+    hshape.trans (TShape.lift_eqv le).2,
+    (WShape.HasType.lift le).2 htype,
+    (hliftTy htype.isType).2 hty, hxy, (hlift htype).2 hrel⟩
+
+/-- Rebase an aligned capture through the packaged equivalence used by a
+target-level constructor continuation. -/
+theorem LRS.CaptureDefEqAligned.rebase
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} {le : n ≤ n'}
+    (E : LogRel.LiftEquiv IH IH' le) :
+    CaptureDefEqAligned IH cap x y typeExpr →
+      CaptureDefEqAligned IH' cap x y typeExpr :=
+  LRS.CaptureDefEqAligned.lift le E.ty E.term
+
+theorem LRS.CaptureDefEqAt.mono (hle : m ≤ m') :
+    CaptureDefEqAt IH m' x y → CaptureDefEqAt IH m x y := by
+  rintro ⟨elemShape, typeShape, typeExpr, hshape, htype, hty, hxy, hrel⟩
+  exact ⟨elemShape, typeShape, typeExpr,
+    hle.trans hshape, htype, hty, hxy, hrel⟩
+
+/-- Lift a capture witness along an explicit logical-relation equivalence.
+There is intentionally no converse for arbitrary high-level witnesses: that
+would require projecting refinements and would recreate the invalid general
+`Shape.WF.plift` principle. -/
+theorem LRS.CaptureDefEqAt.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (hliftTy : ∀ {A B : SExpr} {a : WShape n}, a.HasType .type →
+      (IH'.TyDefEq A B (a.lift n') ↔ IH.TyDefEq A B a))
+    (hlift : ∀ {M N A : SExpr} {m a : WShape n}, m.HasType a →
+      (IH'.DefEq M N A (m.lift n') (a.lift n') ↔ IH.DefEq M N A m a)) :
+    CaptureDefEqAt IH cap x y → CaptureDefEqAt IH' cap x y := by
+  rintro ⟨elemShape, typeShape, typeExpr, hshape, htype, hty, hxy, hrel⟩
+  exact ⟨elemShape.lift n', typeShape.lift n', typeExpr,
+    hshape.trans (TShape.lift_eqv le).2,
+    (WShape.HasType.lift le).2 htype,
+    (hliftTy htype.isType).2 hty, hxy, (hlift htype).2 hrel⟩
+
+/-- Rebase an existential capture through a packaged lift equivalence. -/
+theorem LRS.CaptureDefEqAt.rebase
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} {le : n ≤ n'}
+    (E : LogRel.LiftEquiv IH IH' le) :
+    CaptureDefEqAt IH cap x y → CaptureDefEqAt IH' cap x y :=
+  LRS.CaptureDefEqAt.lift le E.ty E.term
+
+/-- A pair of concrete captures together with the canonical logical-relation
+witness that realizes a (possibly lower) semantic capture shape.  The depth
+is existential because an iota pattern combines recursor arguments and
+constructor fields, which live at adjacent stratification levels. -/
+def LRS.CaptureDefEq (Γ : List SExpr) (m : TShape)
+    (x y : SExpr) : Prop :=
+  ∃ (depth : Nat) (elemShape typeShape : WShape depth) (typeExpr : SExpr),
+    m ≤ elemShape.T ∧ elemShape.HasType typeShape ∧
+    (LR Γ).TyDefEq typeExpr typeExpr typeShape ∧
+    Γ ⊢ x ≡ y : typeExpr ∧
+    (LR Γ).DefEq x y typeExpr elemShape typeShape
+
+theorem LRS.CaptureDefEq.mono (hle : m ≤ m') :
+    CaptureDefEq Γ m' x y → CaptureDefEq Γ m x y := by
+  rintro ⟨depth, elemShape, typeShape, typeExpr,
+    hshape, htype, hty, hxy, hrel⟩
+  exact ⟨depth, elemShape, typeShape, typeExpr,
+    hle.trans hshape, htype, hty, hxy, hrel⟩
+
+/-- Materialize a semantic `varN` match in an arbitrary logical relation.
+The level is fixed by `IH`, so no existential depth is introduced. -/
+theorem LE_Interp.Matches.varN_materializeAt
+    {IH : LogRel Γ n}
+    {c c' : Name} {arity : Nat} {rargs : List (WShape n)}
+    {mcap : (Pattern.varN (.const c) arity).Path → TShape}
+    {xs ys : List SExpr} {ls ls' : List SLevel}
+    (hm : LE_Interp.Matches (Pattern.varN (.const c) arity) c' rargs mcap)
+    (hargs : LRS.CtorArgsDefEq IH xs ys rargs) :
+    c' = c ∧ ∃ mx my,
+      (Pattern.varN (.const c) arity).MatchesS
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ls mx ∧
+      (Pattern.varN (.const c) arity).MatchesS
+        (ys.foldr (fun a f => f.app a) (.const c ls')) ls' my ∧
+      ∀ path, LRS.CaptureDefEqAt IH (mcap path) (mx path) (my path) := by
+  induction arity generalizing c' n rargs xs ys with
+  | zero =>
+    simp only [Pattern.varN] at hm
+    cases hm
+    cases hargs
+    refine ⟨rfl, nofun, nofun, ?_, ?_, nofun⟩
+    · exact .const
+    · exact .const
+  | succ arity ih =>
+    simp only [Pattern.varN] at hm
+    cases hm with
+    | var hm =>
+      cases hargs with
+      | @cons A a x y p xs ys ps hp hty hxy hv hrest =>
+        obtain ⟨rfl, mx, my, hmx, hmy, hcap⟩ := ih hm hrest
+        refine ⟨rfl, (fun path => Option.elim path x mx),
+          (fun path => Option.elim path y my), hmx.var, hmy.var, ?_⟩
+        intro path
+        cases path with
+        | none => exact ⟨_, _, _, TShape.LE.rfl, hp, hty, hxy, hv⟩
+        | some path => exact hcap path
+
+/-- Materialize a semantic `varN` match from the exact related application
+spines that produced it.  This is purely structural: every captured syntax
+pair retains its raw typing equality and its logical-relation witness. -/
+theorem LE_Interp.Matches.varN_materialize
+    {c c' : Name} {arity n : Nat} {rargs : List (WShape n)}
+    {mcap : (Pattern.varN (.const c) arity).Path → TShape}
+    {xs ys : List SExpr} {ls ls' : List SLevel}
+    (hm : LE_Interp.Matches (Pattern.varN (.const c) arity) c' rargs mcap)
+    (hargs : LRS.CtorArgsDefEq (LR Γ) xs ys rargs) :
+    c' = c ∧ ∃ mx my,
+      (Pattern.varN (.const c) arity).MatchesS
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ls mx ∧
+      (Pattern.varN (.const c) arity).MatchesS
+        (ys.foldr (fun a f => f.app a) (.const c ls')) ls' my ∧
+      ∀ path, LRS.CaptureDefEq Γ (mcap path) (mx path) (my path) := by
+  induction arity generalizing c' n rargs xs ys with
+  | zero =>
+    simp only [Pattern.varN] at hm
+    cases hm
+    cases hargs
+    refine ⟨rfl, nofun, nofun, ?_, ?_, nofun⟩
+    · exact .const
+    · exact .const
+  | succ arity ih =>
+    simp only [Pattern.varN] at hm
+    cases hm with
+    | var hm =>
+      cases hargs with
+      | @cons A a x y p xs ys ps hp hty hxy hv hrest =>
+        obtain ⟨rfl, mx, my, hmx, hmy, hcap⟩ := ih hm hrest
+        refine ⟨rfl, (fun path => Option.elim path x mx),
+          (fun path => Option.elim path y my), hmx.var, hmy.var, ?_⟩
+        intro path
+        cases path with
+        | none => exact ⟨_, _, _, _, TShape.LE.rfl, hp, hty, hxy, hv⟩
+        | some path => exact hcap path
+
+/-- Materialize an exact semantic iota match over an arbitrary predecessor
+relation.  Recursor captures are witnessed in `LRS IH`; constructor captures
+remain in `IH`.  This adjacent-level statement is stable under the
+transport operations exposed by `CtorDefEq.fold`. -/
+theorem LE_Interp.Matches.iota_materialize_exactAt
+    {IH : LogRel Γ n}
+    {rec ctor ctor' : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs ctorXs ctorYs : List SExpr}
+    {recLs ctorLs ctorLs' : List SLevel}
+    {majorX majorY : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor' ctorShapes mctor)
+    (hrecargs : LRS.CtorArgsDefEq (LRS IH) recXs recYs recShapes)
+    (hctorargs : LRS.CtorArgsDefEq IH ctorXs ctorYs ctorShapes)
+    (hMajorX : Γ ⊢ majorX ⤳*
+      ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor' ctorLs))
+    (hMajorY : Γ ⊢ majorY ⤳*
+      ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor' ctorLs')) :
+    ∃ mx my,
+      (RecursorIotaPattern rec major ctor arity).MatchesS
+        ((recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)))
+        recLs mx ∧
+      (RecursorIotaPattern rec major ctor arity).MatchesS
+        ((recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')))
+        recLs my ∧
+      (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+        match path with
+        | Sum.inl p => LRS.CaptureDefEqAt (LRS IH) (mrec p) (mx path) (my path)
+        | Sum.inr p => LRS.CaptureDefEqAt IH (mctor p) (mx path) (my path)) ∧
+      Γ ⊢ (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          majorX ⤳*
+        (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)) ∧
+      Γ ⊢ (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          majorY ⤳*
+        (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')) := by
+  obtain ⟨_, mxf, myf, hmxf, hmyf, hcapf⟩ :=
+    hmf.varN_materializeAt (ls := recLs) (ls' := recLs) hrecargs
+  obtain ⟨hctor, mxa, mya, hmxa, hmya, hcapa⟩ :=
+    hma.varN_materializeAt (ls := ctorLs) (ls' := ctorLs') hctorargs
+  subst ctor'
+  refine ⟨Sum.elim mxf mxa, Sum.elim myf mya,
+    hmxf.app hmxa, hmyf.app hmya, ?_, ?_, ?_⟩
+  · intro path
+    cases path with
+    | inl path => exact hcapf path
+    | inr path => exact hcapa path
+  · exact hMajorX.major ⟨_, ⟨_, hpat⟩, _, _, .refl, _, _, hmxf⟩
+  · exact hMajorY.major ⟨_, ⟨_, hpat⟩, _, _, .refl, _, _, hmyf⟩
+
+/-- Materialize an exact semantic iota match once the recursor spine and the
+constructor-field spine have both been exposed.  This canonical wrapper
+forgets the two explicit adjacent relations into existential capture depths. -/
+theorem LE_Interp.Matches.iota_materialize_exact
+    {rec ctor ctor' : Name} {major arity n : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs ctorXs ctorYs : List SExpr}
+    {recLs ctorLs ctorLs' : List SLevel}
+    {majorX majorY : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor' ctorShapes mctor)
+    (hrecargs : LRS.CtorArgsDefEq (LR Γ) recXs recYs recShapes)
+    (hctorargs : LRS.CtorArgsDefEq (LR Γ) ctorXs ctorYs ctorShapes)
+    (hMajorX : Γ ⊢ majorX ⤳*
+      ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor' ctorLs))
+    (hMajorY : Γ ⊢ majorY ⤳*
+      ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor' ctorLs')) :
+    ∃ mx my,
+      (RecursorIotaPattern rec major ctor arity).MatchesS
+        ((recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)))
+        recLs mx ∧
+      (RecursorIotaPattern rec major ctor arity).MatchesS
+        ((recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')))
+        recLs my ∧
+      (∀ path, LRS.CaptureDefEq Γ (Sum.elim mrec mctor path)
+        (mx path) (my path)) ∧
+      Γ ⊢ (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          majorX ⤳*
+        (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)) ∧
+      Γ ⊢ (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          majorY ⤳*
+        (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')) := by
+  obtain ⟨mx, my, hmatchX, hmatchY, hcap, hredX, hredY⟩ :=
+    LE_Interp.Matches.iota_materialize_exactAt
+      (IH := LR Γ) hpat hmf hma hrecargs hctorargs hMajorX hMajorY
+  refine ⟨mx, my, hmatchX, hmatchY, ?_, hredX, hredY⟩
+  intro path
+  cases path with
+  | inl path =>
+    obtain ⟨elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩ :=
+      hcap (Sum.inl path)
+    exact ⟨n + 1, elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩
+  | inr path =>
+    obtain ⟨elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩ :=
+      hcap (Sum.inr path)
+    exact ⟨n, elemShape, typeShape, typeExpr,
+      hshape, htype, hty, hxy, hrel⟩
+
+theorem LRS.PiDefEq.lift
+    {b : WShape n} {f : WShapeFun n} (le : n ≤ n')
+    (htpi : WShape.HasTypePi f b true) :
+    LRS.PiDefEq (LR Γ) B F₁ F₂ (b.lift n') (f.lift n') ↔
+      LRS.PiDefEq (LR Γ) B F₁ F₂ b f :=
+  LRS.PiDefEq.lift_aux le htpi
+    (fun hmt => LR.TyDefEq.lift le hmt)
+    (fun hma => LR.DefEq.lift le hma)
+
 
 def LR.Subst1 (Γ₀ : List SExpr) (x x' A₀ A A' : SExpr) (ρ : Valuation) (i := 0) : Prop :=
   Γ₀ ⊢ x ≡ x' : A ∧ ∀ {{n}} (a : WShape n), LE_Interp ρ a.T A₀ →
@@ -6088,3 +14898,1756 @@ theorem LR.SubstWF.symm (W : LR.SubstWF Γ₀ σ σ' Γ ρ) : LR.SubstWF Γ₀ 
     · exact let ⟨⟨u, h1⟩, h2⟩ := (h0.2 a ha).1 ht; ⟨⟨u, h1.symm⟩, (LR _).symm_ty h2⟩
     · let ⟨_, h2⟩ := (h0.2 a ha).1 hmem.isType
       exact (LR _).conv h2 ((LR _).symm ((h0.2 a ha).2 hM hmem))
+
+/-! ## Shape disjointness, and the CR ladder that reaches `LRS.PiPathInv`
+
+Ported from `plans/probes/probeW-disjointness.lean`.  The §4.4 shape facts
+split into two groups, and the split is exactly where the shape lattice puts
+it.
+
+* *Disjointness* is a statement about **head shapes**, and a head shape is
+  already recorded by `LE_Interp`: `WShape.sort r` and `WShape.forallE b f`
+  are incomparable (`WShape.le_sort`, `WShape.sort_le`), and `LE_Interp.sound`
+  transports a shape across a strong equality.  A sort equated to a Pi would
+  have to carry both shapes at once.  **No fixpoint rung is involved**, which
+  is why the three theorems below take no adequacy hypothesis at all.
+* *Injectivity* is a statement about the **level** `u`, and `WShape.sort`
+  records only `decide (u ≠ .zero)` — see the negative control
+  `LRS.sortInv_bit_only` at the end of this section.  Recovering `u` needs the
+  logical relation's `sort_iff`, hence a genuine adequacy rung; the producers
+  live in `ShapeLogRelAdequacy.lean`, and the rung they need is `0`.
+
+The consequence recorded at the end of the section is that
+`LRS.PiPathInv` — the single residual of the chain wall — follows from the
+Church–Rosser / standardization / subject-reduction rungs **alone**
+(`LRS.PiPathInv.of_crLadder_noAdequacy`), so no cycle runs between it and the
+adequacy fixpoint. -/
+
+/-! ### The four §4.4 facts, restated on `SExpr` -/
+
+/-- `IsDefEqU.sort_forallE_inv` (`Theory/Typing/Injectivity.lean:34`, `sorry`)
+and `Params.structEta_sort_disjoint` (`ChurchRosser.lean:54`), transported. -/
+def LRS.SortForallEDisj : Prop :=
+  ∀ {Γ : List SExpr} {A B : SExpr} {u s : SLevel},
+    Ctx.WF Γ → ¬ IsDefEq Γ (.sort u) (.forallE A B) (.sort s)
+
+/-- "A Pi is not typed at a Pi."  Kills `NormalEq.etaL`; it is what
+`Params.structEta_forallE_disjoint` (`ChurchRosser.lean:61`) is used for at
+`HeadReduction.lean:524`. -/
+def LRS.PiNotFunTyped : Prop :=
+  ∀ {Γ : List SExpr} {A B A₀ B₀ : SExpr},
+    Ctx.WF Γ → ¬ IsDefEq Γ (.forallE A B) (.forallE A B) (.forallE A₀ B₀)
+
+/-- "A Pi is not a proof of a proposition."  Kills `NormalEq.proofIrrel`;
+Theory spends `IsDefEqU.sort_inv` on it at `HeadReduction.lean:527`. -/
+def LRS.PiNotProof : Prop :=
+  ∀ {Γ : List SExpr} {A B p : SExpr},
+    Ctx.WF Γ → IsDefEq Γ p p (.sort .zero) →
+    ¬ IsDefEq Γ (.forallE A B) (.forallE A B) p
+
+/-- `IsDefEqU.sort_inv` (`Theory/Typing/Injectivity.lean:11`, `sorry`), the
+declared L4L-16 gate theorem, transported.  This is the *fourth* §4.4 fact and
+the only one that needs an adequacy rung; the producer is
+`LRS.SortInv.of_adequacyAtDepth_zero` (ADQ), and the rung is `0`. -/
+def LRS.SortInv : Prop :=
+  ∀ {Γ : List SExpr} {u v : SLevel} {V : SExpr},
+    Ctx.WF Γ → IsDefEq Γ (.sort u) (.sort v) V → u = v
+
+/-! ### The shape lattice separates sorts from Pis
+
+Three tiny lemmas plus one transport.  They are the entire semantic content
+of disjointness. -/
+
+/-- A Pi shape never interprets a syntactic sort.  `LE_Interp.le_sort'` says a
+syntactic sort only carries shapes `≤ .sort r`, and `WShape.le_sort` says
+those are `.bot` and `.sort r` only. -/
+theorem LE_Interp.forallE_not_sort {ρ : Valuation} {n : Nat} {b : WShape n}
+    {f : WShapeFun n} {l : SLevel} :
+    ¬ LE_Interp ρ (WShape.T (WShape.forallE b f)) (.sort l) := by
+  intro H
+  have h := LE_Interp.le_sort' H
+  simp only [WShape.T] at h
+  rcases WShape.le_sort.1 h with h | h <;>
+    · have h := congrArg Subtype.val h
+      simp only [WShape.forallE, WShape.bot, WShape.sort, Shape.bot, Shape.sort] at h
+      cases h
+
+/-- Shape inversion at a syntactic Pi: the observed shape is either the bottom
+shape, or below a Pi shape.  Only the `bot` and `forallE` constructors of
+`LE_Interp` can produce a `.forallE` subject. -/
+theorem LE_Interp.forallE_shape_inv {ρ : Valuation} {m : TShape} {B F : SExpr}
+    (H : LE_Interp ρ m (.forallE B F)) :
+    (∃ n', m = WShape.T (n := n') WShape.bot) ∨
+      ∃ (n' : Nat) (b : WShape n') (f : WShapeFun n'),
+        m ≤ WShape.T (WShape.forallE b f) := by
+  cases H with
+  | bot => exact .inl ⟨_, rfl⟩
+  | forallE _ _ _ _ hle => exact .inr ⟨_, _, _, hle⟩
+
+/-- A sort shape never interprets a syntactic Pi. -/
+theorem LE_Interp.sort_not_forallE {ρ : Valuation} {n : Nat} {r : Bool}
+    {B F : SExpr} :
+    ¬ LE_Interp ρ (WShape.T (WShape.sort (n := n) r)) (.forallE B F) := by
+  intro H
+  rcases H.forallE_shape_inv with ⟨n', h⟩ | ⟨n', b, f, hle⟩
+  · obtain ⟨rfl, h⟩ := Sigma.mk.inj h
+    have h := congrArg Subtype.val (eq_of_heq h)
+    simp only [WShape.bot, WShape.sort] at h
+    cases n <;> simp only [Shape.bot, Shape.sort] at h <;> cases h
+  · exact TShape.sort_not_le_forallE hle
+
+/-- A Pi shape is not the bottom shape. -/
+theorem TShape.forallE_not_le_bot {n : Nat} {b : WShape n} {f : WShapeFun n} :
+    ¬ (WShape.forallE b f).T ≤ TShape.bot := by
+  rw [TShape.LE.def (Nat.le_refl (n+1)) (Nat.zero_le (n+1))]
+  simp only [WShape.T, WShape.lift_self, TShape.bot, WShape.lift_bot]
+  intro h
+  have h := congrArg Subtype.val (WShape.le_bot.1 h)
+  simp only [WShape.forallE, WShape.bot, Shape.bot] at h
+  cases h
+
+/-- The minimal Pi observation of a syntactic Pi, available with no hypotheses
+at all.  The same shape `forallE_whRed_l_of_adequacy` (ADQ) builds inline. -/
+theorem LE_Interp.piBot {ρ : Valuation} {n : Nat} {B F : SExpr} :
+    LE_Interp ρ (WShape.T (n := n+1) (.forallE (.bot : WShape n) WShapeFun.bot))
+      (.forallE B F) := by
+  refine .forallE' .bot .bot (.bot <| .bot' .sort) fun _ h => ?_
+  cases h.bot_r
+  exact WShapeFun.bot_app.symm ▸ .bot
+
+/-- **The workhorse.**  A subject observed at the minimal Pi shape really has
+a Pi shape, and therefore a *sort* shape for its type.  This is exactly
+`WShape.HasType.forallE_l` ("the type shape of a Pi shape is a sort shape")
+transported through `InterpTyped.out`'s level alignment. -/
+theorem InterpTyped.piBot_out {Γ : List SExpr} {M N A : SExpr}
+    (d : IsDefEqStrong Γ M N A)
+    (hM : LE_Interp .nil (WShape.T (n := 1) (.forallE (.bot : WShape 0) WShapeFun.bot)) M) :
+    ∃ (k : Nat) (a' : WShape k) (f' : WShapeFun k) (r : Bool),
+      (WShape.forallE a' f').HasType (WShape.sort r) ∧
+      LE_Interp .nil (WShape.T (WShape.sort (n := k + 1) r)) A := by
+  obtain ⟨n', m', a, hn, hle, _, hA, hty⟩ := ((LE_Interp.sound d .nil).2 hM).out
+  have hn1 : 1 ≤ n' := hn
+  obtain ⟨k, rfl⟩ : ∃ k, n' = k + 1 := ⟨n' - 1, by omega⟩
+  rw [TShape.LE.def hn (Nat.le_refl _)] at hle
+  simp only [WShape.T, WShape.lift_self, WShape.lift_forallE (Nat.zero_le k),
+    WShape.lift_bot, WShapeFun.lift_bot] at hle
+  obtain ⟨a', f', _, _, rfl⟩ := WShape.forallE_le.1 hle
+  obtain ⟨r, _, rfl⟩ := WShape.HasType.forallE_l.1 hty
+  exact ⟨k, a', f', r, hty, hA⟩
+
+/-! ### Three of the four facts, from soundness alone
+
+None of the three theorems below takes an adequacy hypothesis, and none of
+them can consume `LR.adequacy` without exposing `sorryAx` in its axiom
+closure (ADQ's single `sorry` sits in `LR.iotaWitnessStep`). -/
+
+/-- **§4.4 fact 2** (`IsDefEqU.sort_forallE_inv`) and **fact 3**
+(`Params.structEta_sort_disjoint`).  Soundness transports the Pi shape of the
+right endpoint onto the left endpoint, where it meets a syntactic sort. -/
+theorem LRS.SortForallEDisj.of_soundness [Params.Semantic] :
+    LRS.SortForallEDisj := by
+  intro Γ A B u s hΓ h
+  have hPi : LE_Interp .nil
+      (WShape.T (n := 1) (.forallE (.bot : WShape 0) WShapeFun.bot)) (.forallE A B) :=
+    LE_Interp.piBot
+  exact LE_Interp.forallE_not_sort ((LE_Interp.sound (h.strong hΓ) .nil).1.2 hPi)
+
+/-- **§4.4 fact 4** (`Params.structEta_forallE_disjoint`, as spent at
+`HeadReduction.lean:524`).  The type shape of a Pi shape is a sort shape, and
+a sort shape cannot interpret a syntactic Pi. -/
+theorem LRS.PiNotFunTyped.of_soundness [Params.Semantic] :
+    LRS.PiNotFunTyped := by
+  intro Γ A B A₀ B₀ hΓ h
+  obtain ⟨k, a', f', r, _, hA⟩ :=
+    InterpTyped.piBot_out (h.strong hΓ) LE_Interp.piBot
+  exact LE_Interp.sort_not_forallE hA
+
+/-- The `proofIrrel` half.  Theory spends `IsDefEqU.sort_inv` here
+(`HeadReduction.lean:527`); the shape system already knows it, as
+`TShape.HasType.proofIrrel`: everything inhabiting a `Prop`-shaped type is the
+bottom shape, and a Pi shape is not bottom. -/
+theorem LRS.PiNotProof.of_soundness [Params.Semantic] : LRS.PiNotProof := by
+  intro Γ A B p hΓ hp h
+  obtain ⟨k, a', f', r, hPiTy, hA⟩ :=
+    InterpTyped.piBot_out (h.strong hΓ) LE_Interp.piBot
+  -- `p` carries a sort shape; read off that that shape is `Prop`-typed.
+  obtain ⟨a₂, b₂, hle₂, _, hb₂, hty₂⟩ := (LE_Interp.sound (hp.strong hΓ) .nil).2 hA
+  have hb₂' : b₂ ≤ TShape.sort false := by
+    have h0 := LE_Interp.le_sort hb₂
+    simpa using h0
+  have hprop : a₂.HasType (TShape.sort false) :=
+    TShape.HasType.mono_r hb₂' TShape.HasType.sort hty₂
+  -- the Pi's own shape inhabits a `Prop`-shaped type, so it is bottom.
+  exact TShape.forallE_not_le_bot
+    (TShape.HasType.proofIrrel hprop
+      (TShape.HasType.mono_r hle₂ hprop (WShape.HasType.T hPiTy)))
+
+/-! ### The depth ledger for `LRS.SortInv`
+
+`sort_inv` is the one §4.4 fact soundness cannot supply.  The rung it needs is
+**depth 0**, and the reason is one line of `HasTypeStratifiedS`. -/
+
+/-- A syntactic sort is stratified at depth `0`.  `HasTypeStratifiedS.sort'`
+(SExpr:2384) is a *nullary* constructor whose depth index is a free variable,
+so the sort case never consumes depth.  This is exactly the asymmetry with
+`LRS.PiPathInv`, whose subject is an arbitrary type. -/
+theorem HasTypeStratifiedS.sort_zero {Γ : List SExpr} {u : SLevel} :
+    HasTypeStratifiedS Γ (.sort u) (.sort u.succ) true 0 := .base .sort'
+
+/-- Depth-indexed sort/Pi disjointness, in the shape of
+`JointStratifiedPathInversionAt.sortInv` (ADQ). -/
+def LRS.SortForallEDisjAt (depth : Nat) : Prop :=
+  ∀ {Γ : List SExpr} {A B V : SExpr} {u s : SLevel} {core : Bool} {d : Nat},
+    d ≤ depth → Ctx.WF Γ → HasTypeStratifiedS Γ (.sort u) V core d →
+    ¬ IsDefEq Γ (.sort u) (.forallE A B) (.sort s)
+
+/-- Depth-indexed sort injectivity, matching `JointStratifiedInversionAt`. -/
+def LRS.SortInvAt (depth : Nat) : Prop :=
+  ∀ {Γ : List SExpr} {u v : SLevel} {V B : SExpr} {core : Bool} {d : Nat},
+    d ≤ depth → Ctx.WF Γ → IsDefEq Γ (.sort u) (.sort v) V →
+    HasTypeStratifiedS Γ (.sort u) B core d → u = v
+
+/-- **Faithfulness, at depth 0.**  The depth-indexed form at `d = 0` already
+implies the bare form the consumers use, because the certificate it demands is
+`HasTypeStratifiedS.sort_zero`, which holds unconditionally. -/
+theorem LRS.SortForallEDisj.of_at_zero (h : LRS.SortForallEDisjAt 0) :
+    LRS.SortForallEDisj :=
+  fun hΓ => h (Nat.le_refl 0) hΓ HasTypeStratifiedS.sort_zero
+
+/-- **Faithfulness, at depth 0**, for sort injectivity. -/
+theorem LRS.SortInv.of_at_zero (h : LRS.SortInvAt 0) : LRS.SortInv :=
+  fun hΓ hEq => h (Nat.le_refl 0) hΓ hEq HasTypeStratifiedS.sort_zero
+
+theorem LRS.SortForallEDisjAt.of_soundness [Params.Semantic] (depth : Nat) :
+    LRS.SortForallEDisjAt depth :=
+  fun _ hΓ _ => LRS.SortForallEDisj.of_soundness hΓ
+
+/-- All four §4.4 facts as one package.  The pass records here that three of
+its four fields need no input at all; only `sortInv` has a producer, and that
+producer sits at rung `0` (`LRS.ShapeDisj.of_lowerAdequacy`, ADQ).
+
+Deliberately *not* depth-indexed: `PiNotFunTyped` and `PiNotProof` have an
+arbitrary Pi as subject, so recovering a bare form from a depth-`d` form would
+need a stratification certificate for an arbitrary type at a fixed depth, i.e.
+`LRS.PathRestratifyAt`-strength uniform depth bound, which collapses the depth
+hierarchy.  They are proved outright instead. -/
+structure LRS.ShapeDisj : Prop where
+  sortInv : LRS.SortInv
+  sortForallEDisj : LRS.SortForallEDisj
+  piNotFunTyped : LRS.PiNotFunTyped
+  piNotProof : LRS.PiNotProof
+
+/-! ### The CR ladder
+
+Everything from `LRS.SubjectRedS` to `LRS.PiPathInv.of_crLadder` transports a
+Church–Rosser / standardization fact from `Theory/Typing/ChurchRosser.lean`
+and `Theory/Typing/HeadReduction.lean`.  Not one of them is an adequacy
+rung. -/
+
+/-- Weak-head subject reduction (`SExpr.WHRedS.defeq`, plus `Ctx.WF`). -/
+def LRS.SubjectRedS : Prop :=
+  ∀ {Γ : List SExpr} {e₁ e₂ A : SExpr},
+    Ctx.WF Γ → WHRedS Γ e₁ e₂ → IsDefEq Γ e₁ e₁ A → IsDefEq Γ e₁ e₂ A
+
+/-- Pi injectivity for a single ordinary equality between two syntactic Pis. -/
+def LRS.PiEdgeInv : Prop :=
+  ∀ {Γ : List SExpr} {A B A' B' : SExpr} {s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ (.forallE A B) (.forallE A' B') (.sort s) →
+    ∃ u v, TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+
+/-- Pi-headedness is stable under ordinary type equality. -/
+def LRS.PiHeadNorm : Prop :=
+  ∀ {Γ : List SExpr} {X Y A B : SExpr} {s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ X Y (.sort s) → WHRedS Γ X (.forallE A B) →
+    ∃ A' B', WHRedS Γ Y (.forallE A' B')
+
+/-- `VEnv.IsDefEq.church_rosser` (ChurchRosser:1952), transported. -/
+def LRS.CRComplete : Prop :=
+  ∀ {Γ : List SExpr} {e₁ e₂ A : SExpr},
+    Ctx.WF Γ → IsDefEq Γ e₁ e₂ A → CRDefEq Γ e₁ e₂ A
+
+/-- `NormalEq` inversion when the right endpoint is a Pi. -/
+def LRS.NormalEqPiInvL : Prop :=
+  ∀ {Γ : List SExpr} {e A B X : SExpr},
+    Ctx.WF Γ → NormalEq Γ e (.forallE A B) X → ∃ A' B', e = .forallE A' B'
+
+/-- The Pi-shaped consequence of standardization (`VEnv.ParRedS.standard`,
+HeadReduction:489, ∘ `VEnv.StRed.forallE_l`). -/
+def LRS.PiStandard : Prop :=
+  ∀ {Γ : List SExpr} {e A B V : SExpr},
+    Ctx.WF Γ → IsDefEq Γ e e V → ParRedS Γ e (.forallE A B) →
+    ∃ A' B', WHRedS Γ e (.forallE A' B')
+
+/-- `VEnv.ParRedS.defeq` (ChurchRosser:1431), transported. -/
+def LRS.ParRedSDefeq : Prop :=
+  ∀ {Γ : List SExpr} {e e' A : SExpr},
+    Ctx.WF Γ → ParRedS Γ e e' → IsDefEq Γ e e A → IsDefEq Γ e e' A
+
+/-- `VEnv.IsDefEq.reduce_forallE` (HeadReduction:512), transported. -/
+def LRS.ReduceForallE : Prop :=
+  ∀ {Γ : List SExpr} {e A B V : SExpr},
+    Ctx.WF Γ → IsDefEq Γ e (.forallE A B) V →
+    ∃ A' B', WHRedS Γ e (.forallE A' B')
+
+/-- Pi *typing* inversion: the domain and codomain of a well-typed syntactic Pi
+are themselves types.  Theory's `VEnv.HasType.forallE_inv`, spent at
+`HeadReduction.lean:516`, transported.
+
+Listed among the ladder `Prop`s for uniformity only — unlike its neighbours it
+is **not** an open rung: `LRS.PiTypeInv.of_strong` proves it outright from
+SExpr's own strong relation, with no Church–Rosser, no standardization and no
+adequacy.  It is the single premise of rung R11 that is not already a named
+rung. -/
+def LRS.PiTypeInv : Prop :=
+  ∀ {Γ : List SExpr} {A B V : SExpr},
+    Ctx.WF Γ → IsDefEq Γ (.forallE A B) (.forallE A B) V →
+    (∃ u, IsDefEq Γ A A (.sort u)) ∧ ∃ v, IsDefEq (A :: Γ) B B (.sort v)
+
+theorem ParRed.forallE_inv {Γ : List SExpr} {A B e : SExpr}
+    (H : ParRed Γ (.forallE A B) e) :
+    ∃ A' B', e = .forallE A' B' ∧ ParRed Γ A A' ∧ ParRed (A :: Γ) B B' := by
+  cases H with
+  | forallE h1 h2 => exact ⟨_, _, rfl, h1, h2⟩
+  | extra action _ =>
+    obtain ⟨c, ls, args, heq, _⟩ := action.matched.head_spine
+    cases args <;> cases heq
+
+theorem ParRedS.forallE_inv {Γ : List SExpr} {A B e : SExpr}
+    (H : ParRedS Γ (.forallE A B) e) : ∃ A' B', e = .forallE A' B' := by
+  induction H with
+  | rfl => exact ⟨_, _, rfl⟩
+  | tail _ h2 ih =>
+    obtain ⟨_, _, rfl⟩ := ih
+    obtain ⟨_, _, rfl, _, _⟩ := h2.forallE_inv
+    exact ⟨_, _, rfl⟩
+
+theorem LRS.ReduceForallE.of_ladder (cr : LRS.CRComplete)
+    (neInv : LRS.NormalEqPiInvL) (std : LRS.PiStandard) : LRS.ReduceForallE := by
+  intro Γ e A B V hΓ H
+  obtain ⟨_, e₁', e₂', h1, h2, h3⟩ := cr hΓ H
+  obtain ⟨_, _, rfl⟩ := ParRedS.forallE_inv h2
+  obtain ⟨_, _, rfl⟩ := neInv hΓ h3
+  exact std hΓ H.hasType.1 h1
+
+theorem LRS.PiHeadNorm.of_reduceForallE (sr : LRS.SubjectRedS)
+    (rf : LRS.ReduceForallE) : LRS.PiHeadNorm := by
+  intro Γ X Y A B s hΓ h hred
+  exact rf hΓ (h.symm.trans (sr hΓ hred h.hasType.1))
+
+theorem LRS.PiHeadNorm.of_crLadder (sr : LRS.SubjectRedS) (cr : LRS.CRComplete)
+    (neInv : LRS.NormalEqPiInvL) (std : LRS.PiStandard) : LRS.PiHeadNorm :=
+  LRS.PiHeadNorm.of_reduceForallE sr (LRS.ReduceForallE.of_ladder cr neInv std)
+
+theorem LRS.SubjectRedS.of_parRedSDefeq (h : LRS.ParRedSDefeq) :
+    LRS.SubjectRedS :=
+  fun hΓ hred he => h hΓ hred.parRedS he
+
+/-- **`NormalEq` inversion is a shape fact.**  The only two `NormalEq`
+constructors that could put a non-Pi on the left of a Pi are `etaL` and
+`proofIrrel`, and both are refuted by Part 2's soundness-derived
+disjointness. -/
+theorem LRS.NormalEqPiInvL.of_parts (h1 : LRS.PiNotFunTyped)
+    (h2 : LRS.PiNotProof) : LRS.NormalEqPiInvL := by
+  have go : ∀ {Γ : List SExpr} {e₁ e₂ Y : SExpr}, NormalEq Γ e₁ e₂ Y →
+      Ctx.WF Γ → ∀ (A' B' : SExpr), e₂ = .forallE A' B' →
+      ∃ A'' B'', e₁ = .forallE A'' B'' := by
+    intro Γ e₁ e₂ Y H
+    induction H with
+    | refl _ => intro _ A' B' h; exact ⟨A', B', h⟩
+    | appDF _ _ _ _ _ => intro _ _ _ h; cases h
+    | lamDF _ _ _ _ _ => intro _ _ _ h; cases h
+    | forallEDF _ _ _ _ _ _ => intro _ _ _ _; exact ⟨_, _, rfl⟩
+    | etaL _ _ he' _ _ => intro hΓ _ _ h; subst h; exact absurd he' (h1 hΓ)
+    | etaR _ _ _ _ _ => intro _ _ _ h; cases h
+    | proofIrrel hp _ hh' => intro hΓ _ _ h; subst h; exact absurd hh' (h2 hΓ hp)
+    | defeqDF _ _ ih => exact ih
+  intro Γ e A B X hΓ H
+  exact go H hΓ _ _ rfl
+
+/-- The single-edge Pi observation. -/
+def LRS.PiEdgeObs : Prop :=
+  ∀ {Γ : List SExpr} {X Y A B : SExpr} {s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ X Y (.sort s) → WHRedS Γ X (.forallE A B) →
+    ∃ A' B' u v, WHRedS Γ Y (.forallE A' B') ∧
+      TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+
+/-- Component half of the single-edge Pi observation. -/
+def LRS.PiEdgeInvObs : Prop :=
+  ∀ {Γ : List SExpr} {X Y A B A' B' : SExpr} {s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ X Y (.sort s) →
+    WHRedS Γ X (.forallE A B) → WHRedS Γ Y (.forallE A' B') →
+    ∃ u v, TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+
+theorem LRS.PiPathInv.of_piEdgeObs (obs : LRS.PiEdgeObs) : LRS.PiPathInv := by
+  intro Γ A B A' B' s hΓ H
+  have go : ∀ {X Y t A₀ B₀ : _}, TypeDefEqPath Γ X Y t →
+      WHRedS Γ X (.forallE A₀ B₀) →
+      ∃ AY BY u v, WHRedS Γ Y (.forallE AY BY) ∧
+        TypeDefEqPath Γ A₀ AY u ∧ TypeDefEqPath (A₀ :: Γ) B₀ BY v := by
+    intro X Y t A₀ B₀ P
+    induction P generalizing A₀ B₀ with
+    | single h => intro hred; exact obs hΓ h hred
+    | trans _ _ ih₁ ih₂ =>
+      intro hred
+      obtain ⟨AY, BY, u₁, v₁, hredY, hdom₁, hcod₁⟩ := ih₁ hred
+      obtain ⟨AZ, BZ, _, _, hredZ, hdom₂, hcod₂⟩ := ih₂ hredY
+      obtain ⟨_, hdom₁'⟩ := hdom₁.symm
+      exact ⟨AZ, BZ, u₁, v₁, hredZ, .trans hdom₁ hdom₂,
+        .trans hcod₁ (hdom₁'.defeqDF_l_path hcod₂)⟩
+  obtain ⟨_, _, u, v, hfinal, hdom, hcod⟩ := go H .rfl
+  cases WHNF.forallE.whRedS hfinal
+  exact ⟨u, v, hdom, hcod⟩
+
+theorem LRS.PiEdgeObs.of_parts (inv : LRS.PiEdgeInvObs)
+    (norm : LRS.PiHeadNorm) : LRS.PiEdgeObs := by
+  intro Γ X Y A B s hΓ h hred
+  obtain ⟨A', B', hredY⟩ := norm hΓ h hred
+  obtain ⟨u, v, hdom, hcod⟩ := inv hΓ h hred hredY
+  exact ⟨A', B', u, v, hredY, hdom, hcod⟩
+
+theorem LRS.PiEdgeInvObs.of_parts (sr : LRS.SubjectRedS)
+    (inv : LRS.PiEdgeInv) : LRS.PiEdgeInvObs := by
+  intro Γ X Y A B A' B' s hΓ h hredX hredY
+  exact inv hΓ ((sr hΓ hredX h.hasType.1).symm.trans (h.trans (sr hΓ hredY h.hasType.2)))
+
+theorem LRS.PiPathInv.of_crLadder (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete)
+    (std : LRS.PiStandard) (nf : LRS.PiNotFunTyped) (np : LRS.PiNotProof)
+    (inv : LRS.PiEdgeInv) : LRS.PiPathInv :=
+  have sr : LRS.SubjectRedS := LRS.SubjectRedS.of_parRedSDefeq srp
+  LRS.PiPathInv.of_piEdgeObs
+    (LRS.PiEdgeObs.of_parts (LRS.PiEdgeInvObs.of_parts sr inv)
+      (LRS.PiHeadNorm.of_crLadder sr cr (LRS.NormalEqPiInvL.of_parts nf np) std))
+
+/-- **HEADLINE.**  The 16C′ leaf follows from the L4L-18A′ rungs **alone**.
+Every hypothesis is a Church–Rosser / standardization / subject-reduction fact
+about `Theory/Typing/ChurchRosser.lean` and `Theory/Typing/HeadReduction.lean`;
+not one of them is an adequacy rung, and the two semantic side conditions
+(`LRS.PiNotFunTyped`, `LRS.PiNotProof`) are discharged here from soundness.
+
+Consequently the suspected 16C′ ⇄ **ADQ-fixpoint** cycle does not exist: the
+18A′ rungs need no adequacy input, so they can be scheduled independently of
+the ADQ fixpoint.
+
+**Superseded gloss, corrected 2026-08-15.**  This used to be read as "16C′ ⇄
+18A′ has no cycle", i.e. as making the leaf schedulable.  It does not.  The
+18A′ rungs are independent of the *adequacy fixpoint* but not of the *leaf*:
+`LRS.ParRedSDefeq` and `LRS.CRComplete` are downstream of `LRS.PiPathInv`
+itself.  The loop is written out on `LRS.crComplete_is_the_last_input`
+below. -/
+theorem LRS.PiPathInv.of_crLadder_noAdequacy [Params.Semantic]
+    (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete) (std : LRS.PiStandard)
+    (inv : LRS.PiEdgeInv) : LRS.PiPathInv :=
+  LRS.PiPathInv.of_crLadder srp cr std
+    LRS.PiNotFunTyped.of_soundness LRS.PiNotProof.of_soundness inv
+
+/-- The same for `LRS.PiHeadNorm`, the irreducible factor. -/
+theorem LRS.PiHeadNorm.of_crLadder_noAdequacy [Params.Semantic]
+    (sr : LRS.SubjectRedS) (cr : LRS.CRComplete) (std : LRS.PiStandard) :
+    LRS.PiHeadNorm :=
+  LRS.PiHeadNorm.of_crLadder sr cr
+    (LRS.NormalEqPiInvL.of_parts LRS.PiNotFunTyped.of_soundness
+      LRS.PiNotProof.of_soundness) std
+
+/-! ### Rung R11 — single-edge Pi injectivity, from Church–Rosser
+
+`LRS.PiEdgeInv` is the last hypothesis of `LRS.PiPathInv.of_crLadder` above
+with no producer; L4L-18A′ §5 records it as rung R11 with a sketch only.  This
+subsection proves it from the ladder rungs.  Ported from
+`plans/probes/probeR11-piedgeinv.lean`, which imports `ShapeLogRel` and nothing
+else — so independence from the *adequacy fixpoint* is structural there and is
+confirmed here by the absence of `sorryAx` in the axiom closures.
+
+**What R11 is, and is not (2026-08-15).**  It is an *interderivability*
+result, not a reduction.  `LRS.PiEdgeInv.of_piPathInv` runs the other
+direction in one line, and the ladder rungs R11 consumes are themselves
+downstream of `LRS.PiPathInv` — the loop is written out on
+`LRS.crComplete_is_the_last_input` at the end of this subsection.  So R11
+narrows the leaf's *presentation* (single-edge Pi injectivity suffices; the
+path-valued form is not independently needed) without making the leaf cheaper.
+Everything below is true and `sorryAx`-free; only the scheduling gloss that
+originally accompanied the sketch was wrong.
+
+Two facts about R11's *price* are worth stating up front, because both narrow
+the recorded ladder.
+
+**R11 sits strictly below the `PiHeadNorm` rung, not beside it.**  Not one
+step of the proof performs a weak-head reduction: `LRS.PiStandard`,
+`LRS.PiHeadNorm`, `LRS.ReduceForallE` and `LRS.TypeWHNFEx` are all absent.  The
+`≫*` chains supplied by `LRS.CRComplete` are consumed *as chains*, by
+`LRS.parRedS_forallE_path`; nothing ever needs them standardized into a
+weak-head sequence.
+
+**R11 costs `LRS.PiNotProof` but not `LRS.PiNotFunTyped`** — one of the two
+sort facts that `LRS.NormalEqPiInvL.of_parts` spends, not both.  The reason is
+that R11 already knows *both* `NormalEq` endpoints are Pis (Part 2 put them
+there), which makes the two eta cases structural: `etaL`/`etaR` each place a
+`.lam` node on one side, and a `.lam` is not a `.forallE`, so `cases` closes
+them.  `LRS.NormalEqPiInvL`, which knows only the right endpoint's shape, has
+to refute `etaL` semantically and therefore does need `LRS.PiNotFunTyped`.
+Six of the eight `NormalEq` constructors are structural here; `refl` costs
+`LRS.PiTypeInv` (proved outright) and `proofIrrel` costs `LRS.PiNotProof`
+(proved from soundness above). -/
+
+/-- **R11, Part 1.**  `LRS.PiTypeInv` is not an open obligation: it follows
+from SExpr's own strong-relation machinery — `IsDefEq.strong` (SExpr:3013)
+crossing the weak/strong bridge, then `IsDefEqStrong.forallE_inv'`
+(SExpr:2284), whose docstring notes that it "does not appeal to weak type
+uniqueness or Church–Rosser".  No Church–Rosser, no normalization, no
+adequacy.
+
+Since the `Prop` is inhabited, its vacuity question is settled affirmatively:
+it cannot be false. -/
+theorem LRS.PiTypeInv.of_strong [Params.Semantic] : LRS.PiTypeInv := by
+  intro Γ A B V hΓ H
+  obtain ⟨⟨u, hA⟩, v, hB⟩ := (H.strong hΓ).forallE_inv' (.inl rfl)
+  exact ⟨⟨u, hA.defeq⟩, v, hB.defeq⟩
+
+/-- **R11, Part 2.**  A `≫*` chain out of a well-typed Pi lands on a Pi, and
+its two components are joined to the originals by ordinary type paths in the
+*fixed* contexts `Γ` and `A :: Γ`.
+
+Charges `LRS.ParRedSDefeq` once per component per step and nothing else; in
+particular it charges neither Church–Rosser nor standardization.
+
+Iterating `ParRed.forallE_inv` along the chain and *then* converting is not an
+option, and this is the reason the statement is path-valued rather than
+equality-valued:
+
+* the codomain components of successive steps live in the successive contexts
+  `A₀ :: Γ`, `A₁ :: Γ`, …, whereas the conclusion wants the single context
+  `A :: Γ`, and SExpr's `ParRed` has no context-conversion lemma to move them
+  (it is ported only at `rfl` and `weak'`).  The fix is to convert *as we go*:
+  each step becomes an ordinary type equality via `LRS.ParRedSDefeq`
+  immediately, and `TypeDefEqPath.defeqDF_l` walks the codomain from `Aₖ :: Γ`
+  to `A :: Γ` one edge at a time.
+* adjacent edges may type their shared endpoint in different universes, so
+  collapsing the accumulated path into a single equality would charge
+  `TypeDefEqPath.collapse`, i.e. raw type uniqueness — precisely the currency
+  the path representation exists to avoid spending. -/
+theorem LRS.parRedS_forallE_path (srp : LRS.ParRedSDefeq)
+    {Γ : List SExpr} {A B e : SExpr} {u v : SLevel}
+    (hΓ : Ctx.WF Γ) (hA : IsDefEq Γ A A (.sort u))
+    (hB : IsDefEq (A :: Γ) B B (.sort v))
+    (H : ParRedS Γ (.forallE A B) e) :
+    ∃ A₁ B₁, e = .forallE A₁ B₁ ∧
+      TypeDefEqPath Γ A A₁ u ∧ TypeDefEqPath (A :: Γ) B B₁ v := by
+  induction H with
+  | rfl => exact ⟨A, B, rfl, .single hA, .single hB⟩
+  | tail _ h2 ih =>
+    obtain ⟨A₁, B₁, rfl, PA, PB⟩ := ih
+    obtain ⟨A₂, B₂, rfl, r1, r2⟩ := h2.forallE_inv
+    obtain ⟨w, hA₁⟩ := PA.rightType
+    have s1 : ParRedS Γ A₁ A₂ := .tail .rfl r1
+    have hdom : IsDefEq Γ A₁ A₂ (.sort w) := srp hΓ s1 hA₁
+    obtain ⟨w', hB₁⟩ := PB.rightType
+    have hΓ₁ : Ctx.WF (A₁ :: Γ) := ⟨hΓ, w, hA₁⟩
+    have s2 : ParRedS (A₁ :: Γ) B₁ B₂ := .tail .rfl r2
+    have hcod : IsDefEq (A₁ :: Γ) B₁ B₂ (.sort w') := srp hΓ₁ s2 (PA.defeqDF_l hB₁)
+    obtain ⟨_, PAsym⟩ := PA.symm
+    exact ⟨A₂, B₂, rfl, PA.trans (.single hdom),
+      PB.trans (.single (PAsym.defeqDF_l hcod))⟩
+
+/-- **R11, Part 3.**  A `NormalEq` between two syntactic Pis yields ordinary
+equalities of the domains and of the codomains, the latter in the *left*
+domain's context.
+
+This is the component-level strengthening of `LRS.NormalEqPiInvL`, which reads
+off only the *shape* of the left endpoint — and it is strictly cheaper, since
+knowing both endpoints are Pis makes `etaL`/`etaR` structural and so drops the
+`LRS.PiNotFunTyped` premise (see the section header).
+
+The `forallEDF` case is the reason the codomain context has to be adjusted:
+that constructor relates `E₁` and `E₂` in the context of a third type that both
+domains convert to, so its component equality is transported to `D₁ :: Γ` along
+the edge it carries. -/
+theorem LRS.normalEqPiInv (pti : LRS.PiTypeInv) (np : LRS.PiNotProof)
+    {Γ : List SExpr} {D₁ E₁ D₂ E₂ X : SExpr} (hΓ : Ctx.WF Γ)
+    (H : NormalEq Γ (.forallE D₁ E₁) (.forallE D₂ E₂) X) :
+    (∃ w, IsDefEq Γ D₁ D₂ (.sort w)) ∧
+      ∃ w', IsDefEq (D₁ :: Γ) E₁ E₂ (.sort w') := by
+  have go : ∀ {Γ : List SExpr} {e₁ e₂ X : SExpr}, NormalEq Γ e₁ e₂ X →
+      Ctx.WF Γ → ∀ (D₁ E₁ D₂ E₂ : SExpr),
+        e₁ = .forallE D₁ E₁ → e₂ = .forallE D₂ E₂ →
+        (∃ w, IsDefEq Γ D₁ D₂ (.sort w)) ∧
+          ∃ w', IsDefEq (D₁ :: Γ) E₁ E₂ (.sort w') := by
+    intro Γ e₁ e₂ X H
+    induction H with
+    | refl h =>
+      intro hΓ _ _ _ _ h1 h2
+      subst h1; injection h2 with p q; subst p; subst q
+      exact pti hΓ h
+    | appDF _ _ _ _ _ => intro _ _ _ _ _ h1 _; cases h1
+    | lamDF _ _ _ _ _ => intro _ _ _ _ _ h1 _; cases h1
+    | forallEDF hA₁ _ hA hB _ _ =>
+      intro _ _ _ _ _ h1 h2
+      injection h1 with p q; subst p; subst q
+      injection h2 with p q; subst p; subst q
+      exact ⟨⟨_, hA.defeq⟩, _, hA₁.symm.defeqDF_l hB.defeq⟩
+    | etaL _ _ _ _ _ => intro _ _ _ _ _ h1 _; cases h1
+    | etaR _ _ _ _ _ => intro _ _ _ _ _ _ h2; cases h2
+    | proofIrrel hp hh _ => intro hΓ _ _ _ _ h1 _; subst h1; exact absurd hh (np hΓ hp)
+    | defeqDF _ _ ih => exact ih
+  exact go H hΓ _ _ _ _ rfl rfl
+
+/-- **HEADLINE — L4L-18A′ rung R11.**  Single-edge Pi injectivity from
+Church–Rosser, supplying the one hypothesis of `LRS.PiPathInv.of_crLadder`
+that had no producer.  (Not a reduction of the leaf — see the subsection
+header and `LRS.crComplete_is_the_last_input`.)
+
+`LRS.CRComplete` splits the edge into two `≫*` chains meeting at a `NormalEq`;
+Part 2 turns each chain into a pair of type paths with fixed contexts; Part 3
+extracts the two component equalities at the meeting point; the three pieces
+are then concatenated, with the right-hand codomain path transported from
+`A' :: Γ` to `A :: Γ` along the assembled domain path.
+
+No `WHRedS`, no `LRS.PiStandard`, no `LRS.PiHeadNorm`, no `LRS.TypeWHNFEx`, no
+`LRS.PiNotFunTyped`.  The three premises beyond `LRS.PiTypeInv` (proved) are
+all rungs the leaf already required. -/
+theorem LRS.PiEdgeInv.of_crLadder (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete)
+    (pti : LRS.PiTypeInv) (np : LRS.PiNotProof) : LRS.PiEdgeInv := by
+  intro Γ A B A' B' s hΓ H
+  obtain ⟨⟨u, hA⟩, v, hB⟩ := pti hΓ H.hasType.1
+  obtain ⟨⟨u', hA'⟩, v', hB'⟩ := pti hΓ H.hasType.2
+  obtain ⟨_, e₁', e₂', h1, h2, h3⟩ := cr hΓ H
+  obtain ⟨A₁, B₁, rfl, PA, PB⟩ := LRS.parRedS_forallE_path srp hΓ hA hB h1
+  obtain ⟨A₂, B₂, rfl, PA', PB'⟩ := LRS.parRedS_forallE_path srp hΓ hA' hB' h2
+  obtain ⟨⟨w, hdom⟩, w', hcod⟩ := LRS.normalEqPiInv pti np hΓ h3
+  obtain ⟨_, PA'sym⟩ := PA'.symm
+  have PAA' : TypeDefEqPath Γ A A' u := PA.trans ((TypeDefEqPath.single hdom).trans PA'sym)
+  refine ⟨u, v, PAA', ?_⟩
+  obtain ⟨_, PAsym⟩ := PA.symm
+  obtain ⟨_, PB'sym⟩ := PB'.symm
+  obtain ⟨_, PA'A⟩ := PAA'.symm
+  exact PB.trans ((TypeDefEqPath.single (PAsym.defeqDF_l hcod)).trans
+    (PA'A.defeqDF_l_path PB'sym))
+
+/-- The same, packaged against the two `Prop`s that are discharged outright
+(`LRS.PiTypeInv` from the strong relation, `LRS.PiNotProof` from soundness), so
+that only the ladder rungs remain visible.  R11 therefore consumes **nothing
+the leaf did not already require**. -/
+theorem LRS.PiEdgeInv.of_crLadder_noAdequacy [Params.Semantic]
+    (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete) : LRS.PiEdgeInv :=
+  LRS.PiEdgeInv.of_crLadder srp cr LRS.PiTypeInv.of_strong
+    LRS.PiNotProof.of_soundness
+
+/-- **HEADLINE — the 16C′ leaf from the ladder rungs, with R11 spent.**
+`LRS.PiPathInv.of_crLadder_noAdequacy` closes the leaf from four inputs; R11
+removes the fourth without adding anything, since
+`LRS.PiEdgeInv.of_crLadder_noAdequacy` consumes only the first two of the
+remaining three.  The leaf therefore rests on exactly three ladder rungs.
+
+**Read this as an interderivability result, not a reduction.**  See the
+circularity note on `LRS.crComplete_is_the_last_input` below: the three rungs
+are not independent of the leaf, so this theorem narrows the leaf's
+presentation without making it cheaper. -/
+theorem LRS.PiPathInv.of_crLadder_R11 [Params.Semantic]
+    (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete) (std : LRS.PiStandard) :
+    LRS.PiPathInv :=
+  LRS.PiPathInv.of_crLadder_noAdequacy srp cr std
+    (LRS.PiEdgeInv.of_crLadder_noAdequacy srp cr)
+
+/-- **CORRECTED 2026-08-15 — the name is wrong and the claim it recorded is
+false.  `LRS.CRComplete` is NOT the last input to the L4L-16C′ leaf: the CR
+ladder is CIRCULAR with respect to it.**
+
+The measurement is `plans/probes/probeR12-parredS-clean.lean` (green, no
+`sorryAx`), and it overturns the earlier reading of the axiom closures.
+`VEnv.ParRedS.defeq` and `VEnv.ParRedS.standard` do *not* depend on
+`VEnv.IsDefEq.weakN_iff`, as the superseded note here claimed.  Their `sorry`
+roots are `IsDefEqU.sort_inv` and `IsDefEqU.forallE_inv_stratified` — the
+L4L-16C′ deliverables themselves.  The loop, and every arrow in it is a
+definitional identity or a proved implication:
+
+    LRS.PiPathInv  =  SExpr.forallE_inv          (`LRS.PiPathInv.of_adequacy`,
+                                                   ADQ, is definitionally
+                                                   `TypeDefEqPath.forallE_inv_of_adequacy`)
+      ⇒ IsDefEqU.forallE_inv_stratified
+      ⇒ IsDefEqU.forallE_inv
+      ⇒ VEnv.ParRed.defeq
+      ⇒ VEnv.ParRedS.defeq
+      ⇒ (transport) LRS.ParRedSDefeq
+      ⇒ (rung R11, above) LRS.PiPathInv
+
+The β case is where the dependency is essential, and it is essential for a
+reason worth stating rather than citing: firing β requires reconciling an
+application's *domain* with its abstraction's own domain, which is Pi
+injectivity. The two essential uses are `ParRed.defeq`
+(`Theory/Typing/ChurchRosser.lean`, β case) and `StRed.triangle`
+(`Theory/Typing/HeadReduction.lean`, β case).  Anchor on those *names*: both
+files are being edited concurrently and their line numbers shift.
+
+**Consequence for R11.**  `LRS.PiEdgeInv.of_piPathInv` is a one-liner in the
+other direction, so R11 is a *re-presentation* of the leaf — single-edge Pi
+injectivity and path-valued Pi injectivity are interderivable given the ladder
+— and not a reduction of it to something cheaper.  R11's theorems are all true
+and `sorryAx`-free, and the narrowing they record is real; what is not real is
+the earlier claim that they discharge the leaf.
+
+**Closing ChurchRosser's remaining `sorry` will not help.**  `church_rosser`
+retains the roots `weakN_iff`, `sort_inv` and `forallE_inv_stratified`
+independently of it.
+
+The statement below is retained verbatim because it is *true* — it is a
+correct implication — and because keeping the false gloss's target visible is
+how the ledger records that the arrow does not point where it was thought to.
+It is the name and the old docstring that were wrong. -/
+theorem LRS.crComplete_is_the_last_input [Params.Semantic]
+    (srp : LRS.ParRedSDefeq) (std : LRS.PiStandard) :
+    LRS.CRComplete → LRS.PiPathInv :=
+  fun cr => LRS.PiPathInv.of_crLadder_R11 srp cr std
+
+/-- **The constructor-spine residual, reduced to the leaf and no further.**
+`LRS.CtorSpineTypeUniqPath.of_piPathInv` (:11544) already discharged this from
+`LRS.PiPathInv`; with R11 the chain runs back to the ladder rungs, so the
+constructor-observation route charges **no adequacy rung** and no raw type
+uniqueness.  Its ADQ consumer is `LR.MajorChainAnchorStep`.
+
+What this does *not* say (2026-08-15): that the residual is cheaper than the
+leaf.  The ladder rungs are inside the loop recorded on
+`LRS.crComplete_is_the_last_input`, so the honest reading is
+"`LRS.CtorSpineTypeUniqPath` costs exactly `LRS.PiPathInv`, and in particular
+adds nothing on top of it". -/
+theorem LRS.CtorSpineTypeUniqPath.of_crLadder [Params.Semantic] {Γ : List SExpr}
+    (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete) (std : LRS.PiStandard)
+    (hΓ : Ctx.WF Γ) : LRS.CtorSpineTypeUniqPath Γ :=
+  LRS.CtorSpineTypeUniqPath.of_piPathInv
+    (LRS.PiPathInv.of_crLadder_R11 srp cr std) hΓ
+
+/-! ### Observation-level unfoldings of the logical relation
+
+The residuals of `LR.FixedHeadConvertStep` / `LR.FixedHeadConvertRightValid`
+(ADQ) at each observation.  Kept here because their statements mention only
+`LR`, `LogRel` and `SExpr`; the theorems that name the ADQ obligations sit
+beside those obligations in `ShapeLogRelAdequacy.lean`. -/
+
+/-- The sort analogue of `LRS.PiHeadNorm`; the sort observation's residual.
+It is the SExpr transport of `VEnv.IsDefEq.reduce_sort`
+(`HeadReduction.lean:493`), which Theory *proves*. -/
+def LRS.SortHeadNorm : Prop :=
+  ∀ {Γ : List SExpr} {X Y : SExpr} {w s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ X Y (.sort s) → WHRedS Γ X (.sort w) →
+    ∃ w', WHRedS Γ Y (.sort w')
+
+theorem LR.tyDefEq_sort_self_iff {Γ₀ : List SExpr} {n : Nat} {B : SExpr}
+    {r : Bool} :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq B B (.sort r) ↔ ∃ w, Γ₀ ⊢ B ⤳* .sort w :=
+  ⟨fun h => have ⟨w, h, _⟩ := (LR Γ₀).sort_iff_ty.1 h; ⟨w, h⟩,
+   fun ⟨w, h⟩ => (LR Γ₀).sort_iff_ty.2 ⟨w, h, h⟩⟩
+
+theorem LR.tyDefEq_sort_iff {Γ₀ : List SExpr} {n : Nat} {A B : SExpr}
+    {r : Bool} :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B (.sort r) ↔
+      ∃ w, Γ₀ ⊢ A ⤳* .sort w ∧ Γ₀ ⊢ B ⤳* .sort w := (LR Γ₀).sort_iff_ty
+
+/-- The Pi observation, unfolded.  `LRS.ValTyPi2`'s first two conjuncts are the
+two weak-head reductions: given the left endpoint's, the right endpoint's is
+exactly `LRS.PiHeadNorm`.  The remaining four conjuncts are *semantic
+component* data that the CR ladder does not produce. -/
+theorem LR.tyDefEq_forallE_unfold {Γ₀ : List SExpr} {n : Nat} {M N : SExpr}
+    {b : WShape n} {f : WShapeFun n} :
+    (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq M N (.forallE b f) ↔
+      ∃ B₁ F₁ B₂ F₂ u v,
+        Γ₀ ⊢ M ⤳* .forallE B₁ F₁ ∧ Γ₀ ⊢ N ⤳* .forallE B₂ F₂ ∧
+        TypeDefEqPath Γ₀ B₁ B₂ u ∧ TypeDefEqPath (B₁ :: Γ₀) F₁ F₂ v ∧
+        (LR Γ₀ : LogRel Γ₀ n).TyDefEq B₁ B₂ b ∧
+        LRS.PiDefEq (LR Γ₀ : LogRel Γ₀ n) B₁ F₁ F₂ b f := .rfl
+
+/-- The precise residual at the Pi observation, beside `LRS.PiHeadNorm`: a
+named *component* transport.  The CR ladder covers the head-shape half only. -/
+def LR.PiComponentTransport (Γ₀ : List SExpr) : Prop :=
+  ∀ {n : Nat} {A B B₁ F₁ B₂ F₂ : SExpr} {u : SLevel} {b : WShape n}
+      {f : WShapeFun n},
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f) →
+    Γ₀ ⊢ B ⤳* .forallE B₁ F₁ → Γ₀ ⊢ B ⤳* .forallE B₂ F₂ →
+    ∃ u' v', TypeDefEqPath Γ₀ B₁ B₂ u' ∧ TypeDefEqPath (B₁ :: Γ₀) F₁ F₂ v' ∧
+      (LR Γ₀ : LogRel Γ₀ n).TyDefEq B₁ B₂ b ∧
+      LRS.PiDefEq (LR Γ₀ : LogRel Γ₀ n) B₁ F₁ F₂ b f
+
+/-! ### The convert step is an induction on the shape level
+
+Ported from `plans/probes/probeR12-picomponent.lean`.  The recorded status of
+`LR.PiComponentTransport` was "the one genuinely new residual on the leaf path
+that neither the CR ladder nor the adequacy fixpoint covers".  That is wrong,
+and the correction is structural rather than a new trick.
+
+**The component data at the Pi observation is the *same statement* one shape
+level down.**  Unfolding `TyDefEq A B (.forallE b f)` at level `n+1` exposes
+component obligations at level `n` — `TyDefEq B₁ B₂ b` and, inside
+`LRS.PiDefEq`, `TyDefEq (F.inst a) (F.inst b') (f.app p)`.  So the convert step
+at level `n+1` consumes the convert step at level `n`, and the residual is not
+new: it is the inductive step of an induction on the shape level.  The previous
+account missed it because it unfolded the Pi observation only once and read the
+component conjuncts as *data* rather than as recursive occurrences.
+
+**The two-reduct form is illusory.**  `LR.PiComponentTransport`'s two
+weak-head reductions are both reductions of the *same* `B`, so
+`WHRedS.determ` collapses them (`LR.PiComponentTransport.of_diag`, and the
+converse `.diag`).  There is nothing to reconcile.
+
+**What the induction costs, per shape constructor of `WShape (n+1)`:**
+
+| shape        | obligation                                      |
+| ------------ | ----------------------------------------------- |
+| `bot`        | `True`                                          |
+| `lam`,`ctor` | `True`                                          |
+| `sort r`     | `LRS.SortHeadNorm` + `LRS.SubjectRedS` + `LRS.SortInv` |
+| `forallE b f`| `LRS.PiHeadNorm` + `LRS.SubjectRedS` + `LRS.PiEdgeInv` + level `n` |
+| `indTy`      | `LRS.IndTyHeadNorm` (new, see below)            |
+
+Three of six are `True`; the sort rung is exactly what
+`LR.fixedHeadConvertStep_sort_of_parts` (ADQ) already charged; the Pi rung
+needs `LRS.PiEdgeInv`, which rung R11 above now *proves*.
+
+**G4 is unaffected.**  The induction is on the *shape level*, which is
+orthogonal to the adequacy rung.  `LRS.SortInv` is consumed exactly where it
+was before — at the sort observation, at every level — so the same-rung
+consumption recorded on `LR.FixedHeadConvertStep` neither improves nor worsens.
+-/
+
+/-- Diagonal form of `LR.PiComponentTransport`: one weak-head reduction of `B`,
+not two.  Equivalent to the two-reduct form by `WHRedS.determ`. -/
+def LR.PiComponentTransportDiag (Γ₀ : List SExpr) : Prop :=
+  ∀ {n : Nat} {A B B₁ F₁ : SExpr} {u : SLevel} {b : WShape n} {f : WShapeFun n},
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f) →
+    Γ₀ ⊢ B ⤳* .forallE B₁ F₁ →
+    ∃ u' v', TypeDefEqPath Γ₀ B₁ B₁ u' ∧ TypeDefEqPath (B₁ :: Γ₀) F₁ F₁ v' ∧
+      (LR Γ₀ : LogRel Γ₀ n).TyDefEq B₁ B₁ b ∧
+      LRS.PiDefEq (LR Γ₀ : LogRel Γ₀ n) B₁ F₁ F₁ b f
+
+theorem LR.PiComponentTransport.of_diag {Γ₀ : List SExpr}
+    (h : LR.PiComponentTransportDiag Γ₀) : LR.PiComponentTransport Γ₀ := by
+  intro n A B B₁ F₁ B₂ F₂ u b f hEq hAA hred₁ hred₂
+  cases hred₁.determ WHNF.forallE hred₂ WHNF.forallE
+  exact h hEq hAA hred₁
+
+theorem LR.PiComponentTransport.diag {Γ₀ : List SExpr}
+    (h : LR.PiComponentTransport Γ₀) : LR.PiComponentTransportDiag Γ₀ :=
+  fun hEq hAA hred => h hEq hAA hred hred
+
+/-- `LR.FixedHeadConvertStep` (ADQ), indexed by the shape level so it can be
+proved by induction.  `∀ n, LR.ConvertStepAt Γ₀ n` *is* that obligation. -/
+def LR.ConvertStepAt (Γ₀ : List SExpr) (n : Nat) : Prop :=
+  ∀ {A B : SExpr} {u : SLevel} {a : WShape n},
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A a →
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B a
+
+/-- The convert step lifts from a single ordinary type equality to a whole
+`TypeDefEqPath`, one edge at a time.  This is what lets the Pi rung consume
+`LRS.PiEdgeInv`'s *path*-valued output without ever charging path collapse. -/
+theorem LR.ConvertStepAt.path {Γ₀ : List SExpr} {n : Nat}
+    (conv : LR.ConvertStepAt Γ₀ n) {A B : SExpr} {u : SLevel} {a : WShape n}
+    (P : TypeDefEqPath Γ₀ A B u)
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A a) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B a := by
+  induction P generalizing a with
+  | single h => exact conv h hAA
+  | trans _ _ ih₁ ih₂ =>
+    have h₁ := ih₁ hAA
+    have h₂ := ih₂ ((LR Γ₀).left_ty ((LR Γ₀).symm_ty h₁))
+    exact (LR Γ₀).trans_ty h₁ h₂
+
+theorem LR.ConvertStepAt.path_right {Γ₀ : List SExpr} {n : Nat}
+    (conv : LR.ConvertStepAt Γ₀ n) {A B : SExpr} {u : SLevel} {a : WShape n}
+    (P : TypeDefEqPath Γ₀ A B u)
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A a) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq B B a :=
+  (LR Γ₀).left_ty ((LR Γ₀).symm_ty (LR.ConvertStepAt.path conv P hAA))
+
+/-- The inductive-type analogue of `LRS.SortHeadNorm` and `LRS.PiHeadNorm`:
+an inductive-type head is stable under ordinary type equality.
+
+**This one has no upstream analogue.**  Theory's `reduce_*` family stops at
+`VEnv.IsDefEq.reduce_sort` (`HeadReduction.lean:493`) and
+`VEnv.IsDefEq.reduce_forallE` (`:512`); there is no `reduce_const`.  So unlike
+its two siblings this is a genuinely new named obligation — but it is
+CR-ladder *shaped* (a head-form transport, no semantic component data), not
+adequacy-shaped, and it is the only such residual the level induction
+exposes. -/
+def LRS.IndTyHeadNorm : Prop :=
+  ∀ {Γ : List SExpr} {X Y : SExpr} {s : SLevel},
+    Ctx.WF Γ → IsDefEq Γ X Y (.sort s) → LRS.IndTyHead Γ X → LRS.IndTyHead Γ Y
+
+/-- **Triage (2026-08-15): `LRS.IndTyHeadNorm` is banked-consumer plumbing,
+not leaf-critical.**  Every consumer of `LRS.IndTyHeadNorm` sits inside a
+CR-conditional producer: `LR.convertStepAt_all` and
+`LR.PiComponentTransport.of_crLadder` (below) take the ladder rungs
+`LRS.SubjectRedS` / `LRS.PiHeadNorm` / `LRS.PiEdgeInv` as hypotheses, and
+the three ADQ consumers are `LR.FixedHeadConvertStep.of_crLadder`,
+`LR.FixedHeadConvertRightValid.of_crLadder` and
+`LR.FixedHeadConvertStep.of_crLadder_R11`.  The ladder rungs are
+interderivable with the 16C′ leaf (`LRS.piPathInv_iff_parRedSDefeq`), so
+nothing on the mandatory leaf path consumes this Prop; it fires only in the
+banked consumer direction, after the leaf lands.  This corrects the
+premortem's framing of the rung as a leaf-path residual.
+
+**What soundness does and does not supply.**  The ShapeDisj precedent
+(`LRS.SortForallEDisj.of_soundness` and friends) does not extend to a
+producer here.  `IndTyHeadNorm` factors as
+
+    whr-expansion  ∘  shape transport  ∘  indTy adequacy
+
+and only the middle factor is soundness-shaped — it is this theorem.  The
+left flank — moving `IndTyHead Γ X`'s `WHRedS Γ X spine` into a defeq that
+`LE_Interp.sound` can consume — is exactly `LRS.SubjectRedS` (equivalently a
+direct whr-invariance of `LE_Interp`, which does not exist; the Theory
+mirror `SExpr.WHRedS.defeq` is a `sorry`).  The right flank — recovering
+`WHRedS Γ Y spine'` from `Y` carrying the `indTy` shape — is the adequacy
+fixpoint's `indTy` observation (`LR.adequacy`, ADQ).  Both flanks are
+leaf-equivalent and neither is soundness-derivable, because the conclusion
+`LRS.IndTyHead Γ Y` carries a *syntactic* reduction — which is what
+distinguishes this rung from the refutation-shaped §4.4 facts that
+soundness does prove.  There is also no `Params.Semantic` certificate to
+bridge either flank: its fields (`structureEta`, `ctor`, `defn`,
+`iotaRule`, `iotaSite`) are equational, not normalizing. -/
+theorem LRS.indTyShapeTransport [Params.Semantic] {Γ : List SExpr}
+    {X Y : SExpr} {s : SLevel} {n : Nat} (hΓ : Ctx.WF Γ)
+    (h : IsDefEq Γ X Y (.sort s))
+    (hX : LE_Interp .nil (WShape.indTy : WShape (n+1)).T X) :
+    LE_Interp .nil (WShape.indTy : WShape (n+1)).T Y :=
+  (LE_Interp.sound (h.strong hΓ) .nil).1.1 hX
+
+/--
+info: 'Lean4Lean.SExpr.LRS.indTyShapeTransport' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.indTyShapeTransport
+
+/-- **The Pi rung of the induction.**  Note the conclusion is the
+*heterogeneous* `TyDefEq A B`, which is strictly more convenient than the
+right-endpoint form: `LRS.PiEdgeInv` hands back paths `A₁ ⇝ B₁` and
+`G₁ ⇝ F₁` that slot directly into `LRS.ValTyPi2`'s two `TypeDefEqPath`
+fields, so no path is ever reversed, composed, or collapsed.
+
+The `LRS.PiDefEq` field is where the recursion lives: its `rightTy` component
+is `TyDefEq (F₁.inst a) (F₁.inst b') (f.app p)`, obtained from the `G₁`
+version by converting each endpoint along the substituted codomain path — two
+uses of `LR.ConvertStepAt.path` at level `n`.  Its `rightDefEq` component is
+raw and comes from `IsDefEqStrong.subst` at the equality substitution
+`a ≡ b' : A₁`, charging no semantics at all. -/
+theorem LR.convertStep_forallE [Params.Semantic] {Γ₀ : List SExpr} {n : Nat}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (norm : LRS.PiHeadNorm)
+    (inv : LRS.PiEdgeInv) (lower : LR.ConvertStepAt Γ₀ n)
+    {A B : SExpr} {u : SLevel} {b : WShape n} {f : WShapeFun n}
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f)) :
+    (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A B (.forallE b f) := by
+  obtain ⟨A₁, G₁, A₂, G₂, u₀, v₀, hredA, hredA', hdomA, hcodA, htyA, hpiA⟩ :=
+    LR.tyDefEq_forallE_unfold.1 hAA
+  cases hredA.determ WHNF.forallE hredA' WHNF.forallE
+  obtain ⟨B₁, F₁, hredB⟩ := norm hΓ₀ hEq hredA
+  have hA' : IsDefEq Γ₀ A (.forallE A₁ G₁) (.sort u) := sr hΓ₀ hredA hEq.hasType.1
+  have hB' : IsDefEq Γ₀ B (.forallE B₁ F₁) (.sort u) := sr hΓ₀ hredB hEq.hasType.2
+  obtain ⟨ud, vd, Pdom, Pcod⟩ := inv hΓ₀ (hA'.symm.trans (hEq.trans hB'))
+  obtain ⟨wF, hF₁⟩ := Pcod.rightType
+  have hΓA : Ctx.WF (A₁ :: Γ₀) := ⟨hΓ₀, ud, Pdom.leftType⟩
+  refine LR.tyDefEq_forallE_unfold.2
+    ⟨A₁, G₁, B₁, F₁, ud, vd, hredA, hredB, Pdom, Pcod,
+      LR.ConvertStepAt.path lower Pdom htyA, ?_, ?_⟩
+  · intro a b' p hp hab hsem
+    have hinst := hpiA.1 hp hab hsem
+    have Pa : TypeDefEqPath Γ₀ (G₁.inst a) (F₁.inst a) vd := by
+      simpa only [SExpr.inst] using
+        Pcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar hab.hasType.1)
+    have Pb : TypeDefEqPath Γ₀ (G₁.inst b') (F₁.inst b') vd := by
+      simpa only [SExpr.inst] using
+        Pcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar hab.hasType.2)
+    have cL := LR.ConvertStepAt.path lower Pa ((LR Γ₀).left_ty hinst.leftTy)
+    have cR := LR.ConvertStepAt.path lower Pb ((LR Γ₀).left_ty ((LR Γ₀).symm_ty hinst.leftTy))
+    have W : Ctx.SubstEq Γ₀ (.one a) (.one b') (A₁ :: Γ₀) := by
+      refine .cons .nil Pdom.leftType ?_
+      show Γ₀ ⊢ a ≡ b' : A₁.subst SExpr.Subst.id
+      rw [SExpr.subst_id]; exact hab
+    exact ⟨hinst.leftTy,
+      (LR Γ₀).trans_ty ((LR Γ₀).symm_ty cL) ((LR Γ₀).trans_ty hinst.leftTy cR),
+      hinst.leftDefEq, ⟨wF, (hF₁.strong hΓA).subst W⟩⟩
+  · intro a p hp ha hsem
+    have hinst := hpiA.2 hp ha hsem
+    have Pa : TypeDefEqPath Γ₀ (G₁.inst a) (F₁.inst a) vd := by
+      simpa only [SExpr.inst] using
+        Pcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar ha)
+    exact LR.ConvertStepAt.path lower Pa hinst
+
+/-- **The sort rung of the induction.**  Uniform in the level — the sort
+observation is a `LogRel` *field* (`sort_iff_ty`), not a shape recursion — so
+it never appeals to the inductive hypothesis.  Identical in content to
+`LR.fixedHeadConvertStep_sort_of_parts` (ADQ); restated here because the
+induction needs it at the same level as the other rungs. -/
+theorem LR.convertStep_sort {Γ₀ : List SExpr} {n : Nat}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (snorm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) {A B : SExpr} {u : SLevel} {r : Bool}
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A (.sort r)) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B (.sort r) := by
+  obtain ⟨w, hredA⟩ := LR.tyDefEq_sort_self_iff.1 hAA
+  obtain ⟨w', hredB⟩ := snorm hΓ₀ hEq hredA
+  have hA' : IsDefEq Γ₀ A (.sort w) (.sort u) := sr hΓ₀ hredA hEq.hasType.1
+  have hB' : IsDefEq Γ₀ B (.sort w') (.sort u) := sr hΓ₀ hredB hEq.hasType.2
+  cases sinv hΓ₀ (hA'.symm.trans (hEq.trans hB'))
+  exact LR.tyDefEq_sort_iff.2 ⟨w, hredA, hredB⟩
+
+/-- **HEADLINE — the convert step, at every shape level.**  Induction on the
+level, case split by `WShape.casesOn'`.  Three of the six shape constructors
+are `True` for `LRS.TyDefEq`; the sort rung is level-uniform; only the Pi rung
+recurses; and `indTy` is the single new named residual.
+
+Its consumer `LR.FixedHeadConvertStep` (ADQ) was recorded as "THE ONE MISSING
+INPUT"; this discharges it from CR-ladder rungs, `LRS.SortInv` (adequacy rung
+`0`, unchanged) and `LRS.IndTyHeadNorm`. -/
+theorem LR.convertStepAt_all [Params.Semantic] {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (snorm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) (norm : LRS.PiHeadNorm) (inv : LRS.PiEdgeInv)
+    (ind : LRS.IndTyHeadNorm) : ∀ n, LR.ConvertStepAt Γ₀ n := by
+  intro n
+  induction n with
+  | zero =>
+    intro A B u a hEq hAA
+    obtain ⟨s, wf⟩ := a
+    match s with
+    | .bot => trivial
+    | .sort r => exact LR.convertStep_sort hΓ₀ sr snorm sinv hEq hAA
+  | succ n ih =>
+    intro A B u a hEq hAA
+    cases a using WShape.casesOn' with
+    | bot => trivial
+    | sort r => exact LR.convertStep_sort hΓ₀ sr snorm sinv hEq hAA
+    | forallE b f => exact LR.convertStep_forallE hΓ₀ sr norm inv ih hEq hAA
+    | lam f h => trivial
+    | ctor c l h => trivial
+    | indTy => exact ⟨hAA.1, ind hΓ₀ hEq hAA.1⟩
+
+/-- **The recorded residual, discharged.**  `LR.PiComponentTransport` is not a
+new obligation: the level induction supplies it. -/
+theorem LR.PiComponentTransport.of_crLadder [Params.Semantic] {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (snorm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) (norm : LRS.PiHeadNorm) (inv : LRS.PiEdgeInv)
+    (ind : LRS.IndTyHeadNorm) : LR.PiComponentTransport Γ₀ := by
+  refine LR.PiComponentTransport.of_diag ?_
+  intro n A B B₁ F₁ u b f hEq hAA hredB
+  have step := LR.convertStepAt_all hΓ₀ sr snorm sinv norm inv ind
+  obtain ⟨A₁, G₁, B₁', F₁', ud, vd, hredA, hredB', Pdom, Pcod, hty, hpi⟩ :=
+    LR.tyDefEq_forallE_unfold.1
+      (LR.convertStep_forallE hΓ₀ sr norm inv (step n) hEq hAA)
+  cases hredB.determ WHNF.forallE hredB' WHNF.forallE
+  obtain ⟨wB, hB₁⟩ := Pdom.rightType
+  obtain ⟨wF, hF₁⟩ := Pcod.rightType
+  obtain ⟨_, Pdomsym⟩ := Pdom.symm
+  refine ⟨wB, wF, .single hB₁, .single (Pdom.defeqDF_l hF₁),
+    (LR Γ₀).left_ty ((LR Γ₀).symm_ty hty), ?_, ?_⟩
+  · intro a b' p hp hab hsem
+    have hab' : Γ₀ ⊢ a ≡ b' : A₁ := Pdomsym.defeqDF hab
+    have hsem' : (LR Γ₀ : LogRel Γ₀ n).DefEq a b' A₁ p b :=
+      (LR Γ₀).conv ((LR Γ₀).symm_ty hty) hsem
+    have hinst := hpi.1 hp hab' hsem'
+    exact ⟨hinst.rightTy, hinst.rightTy, hinst.rightDefEq, hinst.rightDefEq⟩
+  · intro a p hp ha hsem
+    have ha' : Γ₀ ⊢ a : A₁ := Pdomsym.defeqDF ha
+    have hsem' : (LR Γ₀ : LogRel Γ₀ n).DefEq a a A₁ p b :=
+      (LR Γ₀).conv ((LR Γ₀).symm_ty hty) hsem
+    have hinst := hpi.1 hp ha' hsem'
+    exact hinst.rightTy
+
+/-! ### Vacuity discipline
+
+Standing policy since 2026-08-15: every new `Prop` either exhibits an
+inhabitant or an attempted derivation of `False`.  The three proved
+disjointness facts are *refutations*, so the risk they carry is that the
+judgment they refute is empty; `LRS.nonvacuous_sort` and `LRS.nonvacuous_pi`
+show it is not.  `LRS.sortInv_bit_only` is the sharp negative control: the
+soundness machinery recovers the `decide (u ≠ .zero)` bit and *nothing more*,
+which is exactly why `LRS.SortInv` still needs a rung.  `LRS.SortHeadNorm` and
+`LR.PiComponentTransport` are inhabited on the diagonal. -/
+
+theorem LRS.nonvacuous_sort {Γ : List SExpr} {u : SLevel} :
+    IsDefEq Γ (.sort u) (.sort u) (.sort u.succ) := .sort
+
+/-- **Negative control — the sharp boundary.**  Soundness alone recovers the
+`decide (u ≠ .zero)` bit shared by two equated sorts, and *nothing more*: the
+level itself is not determined, which is precisely why `LRS.SortInv` still
+needs an adequacy rung while the three disjointness facts do not.
+
+This is also the strongest available evidence that the pass is not vacuous.
+If `[Params] [Params.Semantic]` were inconsistent, or if the soundness
+machinery proved too much, `LRS.SortInv` would fall out of the same two lines
+— it does not. -/
+theorem LRS.sortInv_bit_only [Params.Semantic] {Γ : List SExpr} {V : SExpr}
+    {a b : SLevel} (hΓ : Ctx.WF Γ)
+    (h : IsDefEq Γ (.sort a) (.sort b) V) :
+    decide (a ≠ .zero) = decide (b ≠ .zero) := by
+  have hstart : LE_Interp .nil (TShape.sort (decide (a ≠ .zero))) (.sort a) :=
+    LE_Interp.sort'
+  have hend := (LE_Interp.sound (h.strong hΓ) .nil).1.1 hstart
+  have hle := LE_Interp.le_sort hend
+  rw [TShape.LE.def (Nat.le_refl 0) (Nat.le_refl 0)] at hle
+  simp only [TShape.sort, WShape.T, WShape.lift_self] at hle
+  have hval := congrArg Subtype.val (WShape.sort_le.1 hle)
+  simp only [WShape.sort, Shape.sort] at hval
+  injection hval
+
+theorem LRS.nonvacuous_pi {Γ : List SExpr} {A B : SExpr} {u v : SLevel}
+    (hA : IsDefEq Γ A A (.sort u)) (hB : IsDefEq (A :: Γ) B B (.sort v)) :
+    IsDefEq Γ (.forallE A B) (.forallE A B) (.sort (.imax u v)) :=
+  .forallEDF hA hB
+
+/-- Non-vacuity of `LRS.PiTypeInv`'s hypothesis, in the *empty* context and
+with no environment assumptions at all: a Pi over two sorts is well-typed, so
+the `Prop` proved by `LRS.PiTypeInv.of_strong` has content. -/
+theorem LRS.piTypeInv_nonvacuous (pti : LRS.PiTypeInv) {l l' : SLevel} :
+    (∃ u, IsDefEq [] (.sort l) (.sort l) (.sort u)) ∧
+      ∃ v, IsDefEq [.sort l] (.sort l') (.sort l') (.sort v) :=
+  pti trivial (LRS.nonvacuous_pi .sort .sort)
+
+/-- Non-vacuity of rung R11, at the same witness.  Together with
+`LRS.PiEdgeInv.of_crLadder`, this pins the vacuity question exactly:
+`LRS.PiEdgeInv` is refutable only if `LRS.CRComplete` or `LRS.ParRedSDefeq` is,
+since the other two premises are proved outright. -/
+theorem LRS.piEdgeInv_nonvacuous (inv : LRS.PiEdgeInv) {l l' : SLevel} :
+    ∃ u v, TypeDefEqPath [] (.sort l) (.sort l) u ∧
+      TypeDefEqPath [.sort l] (.sort l') (.sort l') v :=
+  inv trivial (LRS.nonvacuous_pi .sort .sort)
+
+theorem LRS.sortHeadNorm_diagonal {Γ : List SExpr} {X : SExpr} {w : SLevel}
+    (hred : WHRedS Γ X (.sort w)) : ∃ w', WHRedS Γ X (.sort w') := ⟨w, hred⟩
+
+theorem LR.piComponentTransport_diagonal_witness {Γ₀ : List SExpr} {n : Nat}
+    {A : SExpr} {b : WShape n} {f : WShapeFun n}
+    (hAA : (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f)) :
+    ∃ B₁ F₁ u' v', Γ₀ ⊢ A ⤳* .forallE B₁ F₁ ∧
+      TypeDefEqPath Γ₀ B₁ B₁ u' ∧ TypeDefEqPath (B₁ :: Γ₀) F₁ F₁ v' ∧
+      (LR Γ₀ : LogRel Γ₀ n).TyDefEq B₁ B₁ b ∧
+      LRS.PiDefEq (LR Γ₀ : LogRel Γ₀ n) B₁ F₁ F₁ b f := by
+  obtain ⟨B₁, F₁, B₂, F₂, u, v, hred, hred₂, hdom, hcod, hty, hpi⟩ :=
+    LR.tyDefEq_forallE_unfold.1 hAA
+  cases hred.determ WHNF.forallE hred₂ WHNF.forallE
+  exact ⟨B₁, F₁, u, v, hred, hdom, hcod, hty, hpi⟩
+
+/-- Non-vacuity of `LR.PiComponentTransportDiag`, at an arbitrary valid Pi
+observation.  Sharper than the diagonal witness above: the *reduct* is chosen
+by the caller rather than read off the observation, and determinism forces the
+two to agree.  So the conclusion of the diagonal form is inhabited at every
+instance whose hypotheses are, with no ladder input at all — which is exactly
+why `LR.PiComponentTransportDiag` can only fail off the diagonal, where the
+level induction supplies it. -/
+theorem LR.piComponentTransportDiag_nonvacuous {Γ₀ : List SExpr} {n : Nat}
+    {A B₁ F₁ : SExpr} {b : WShape n} {f : WShapeFun n}
+    (hAA : (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f))
+    (hred : Γ₀ ⊢ A ⤳* .forallE B₁ F₁) :
+    ∃ u' v', TypeDefEqPath Γ₀ B₁ B₁ u' ∧ TypeDefEqPath (B₁ :: Γ₀) F₁ F₁ v' ∧
+      (LR Γ₀ : LogRel Γ₀ n).TyDefEq B₁ B₁ b ∧
+      LRS.PiDefEq (LR Γ₀ : LogRel Γ₀ n) B₁ F₁ F₁ b f := by
+  obtain ⟨B₁', F₁', u', v', hredA, hdom, hcod, hty, hpi⟩ :=
+    LR.piComponentTransport_diagonal_witness hAA
+  cases hred.determ WHNF.forallE hredA WHNF.forallE
+  exact ⟨u', v', hdom, hcod, hty, hpi⟩
+
+/-- Non-vacuity of `LR.ConvertStepAt` at a **non-degenerate** shape: a
+syntactic sort is a valid type at the sort observation, at every level and
+every relevance bit, so the Prop's hypothesis is inhabited and its conclusion
+carries content (it forces `B` to reach the *same* sort). -/
+theorem LR.convertStepAt_nonvacuous {Γ₀ : List SExpr} {n : Nat}
+    (conv : LR.ConvertStepAt Γ₀ n) {B : SExpr} {w u : SLevel} {r : Bool}
+    (hEq : IsDefEq Γ₀ (.sort w) B (.sort u)) :
+    ∃ w', Γ₀ ⊢ SExpr.sort w ⤳* .sort w' ∧ Γ₀ ⊢ B ⤳* .sort w' :=
+  LR.tyDefEq_sort_iff.1 (conv (a := .sort r) hEq (LR.tyDefEq_sort_iff.2 ⟨w, .rfl, .rfl⟩))
+
+/-- Non-vacuity of `LRS.IndTyHeadNorm`: its hypothesis is inhabited as soon as
+the environment declares any nullary inductive type.  Unlike the sort and Pi
+witnesses this one is environment-conditional — there is no `Params`-free
+inductive type — which is the honest statement of the residual's scope. -/
+theorem LRS.indTyHead_nonvacuous {Γ : List SExpr} {c : Name} {ls : List SLevel}
+    (h : Params.classify c = some (.indTy 0)) : LRS.IndTyHead Γ (.const c ls) :=
+  ⟨c, ls, [], h, .rfl⟩
+
+/-! ### The Church–Rosser ladder, banked as a *consumer* of the 16C′ leaf
+
+Source: `plans/probes/probeR13-loop.lean` (green; all 22 `#print axioms`
+`sorryAx`-free).  R13 proved that the ladder rung `LRS.ParRedSDefeq` and the
+L4L-16C′ leaf `LRS.PiPathInv` are **interderivable**
+(`LRS.piPathInv_iff_parRedSDefeq` below).  That definitively closes the ladder
+as a way to *discharge* the leaf — any proof of the rung is a proof of the
+leaf, so it is not a cheaper input.  The same fact makes the ladder a valuable
+downstream **consumer**, and the consumer direction is what is banked here.
+
+**The payoff.**  Everything below fires the moment 16C′ lands, and no
+derivation in this block uses Church–Rosser, standardization or adequacy:
+
+* `LRS.parRedSDefeq_of_piPathInv` — the rung `LRS.ParRedSDefeq` outright, from
+  the leaf and nothing else;
+* `WHRedS.defeq_of_piPathInv` (:11549) — the rung `LRS.SubjectRedS`, already
+  landed and definitionally that statement;
+* `LRS.PiEdgeInv.of_piPathInv` — the single-edge rung, and with it
+  `LRS.PiEdgeInvObs.of_parts` (:15308) and `LRS.PiEdgeObs.of_parts` (:15301)
+  as soon as `LRS.PiHeadNorm` is in hand.
+
+So the leaf pays for the ladder, not the other way round.  It also retires the
+`sorryAx` that Theory's `VEnv.ParRed.defeq` (`Theory/Typing/ChurchRosser.lean`)
+and `VEnv.StRed.triangle` (`Theory/Typing/HeadReduction.lean`) currently carry:
+probeR12 measured their roots as `IsDefEqU.sort_inv` /
+`IsDefEqU.forallE_inv_stratified`, i.e. the 16C′ deliverables themselves.
+Anchor on those *names* — both files move.
+
+Structurally the derivation is Theory's `VEnv.ParRed.defeq` with every
+`IsDefEq.trans_l` / `uniqU` fixup replaced by the declared-type path returned
+by the SExpr inversion suite (`IsDefEqStrong.app_inv'` SExpr:3705,
+`.lam_inv'` :3753, `.forallE_inv_path` :3804).  The leaf is charged **exactly
+once**, in the `beta` case, and its bare output is consumed only by
+`TypeDefEqPath.defeqDF` / `.subst` on unindexed judgments, after both
+inductive hypotheses have already fired at inversion-supplied types. -/
+
+/-- **The pattern-contraction rung — the second, independent uniqueness
+site.**  A registered contraction carries its local equality only at the type
+`A` that the `Pattern.Action` chose; using it at the type `V` at which the
+redex is actually typed is Theory's `IsDefEqU.defeqU_l`, i.e. **type
+uniqueness**.  It is isolated here because it is *not* Π-injectivity:
+`LRS.PatStep.of_typeUniq` proves it from raw type uniqueness and from nothing
+whatever about Pi shapes.
+
+It is nevertheless not an extra residual on top of the leaf.  Every redex a
+`Pattern.Action` can match is a constant-headed spine, and spine type
+uniqueness is already reduced to the leaf here (`LRS.constSpineTypeUniqPath`,
+:11458), so `LRS.PatStep.of_piPathInv` discharges it from `LRS.PiPathInv` too
+— exactly as the `extra` case of `WHRed.defeq_of_piPathInv` (:11507) already
+does for weak-head steps. -/
+def LRS.PatStep : Prop :=
+  ∀ {Γ : List SExpr} {p : Pattern} {r : p.RHS × p.Check} {e V A : SExpr}
+    {m1 : List SLevel} {m2 : p.Path → SExpr},
+    Ctx.WF Γ → Pattern.Action Γ r e m1 m2 A → IsDefEq Γ e e V →
+    IsDefEq Γ e (r.1.applyS m1 m2) V
+
+/-- The pattern rung follows from raw type uniqueness, and from nothing about
+Pi shapes.  This pins its content: it is a retyping step, not an inversion. -/
+theorem LRS.PatStep.of_typeUniq (uniq : LogRel.ContextualRawTypeUniq) :
+    LRS.PatStep := by
+  intro Γ p r e V A m1 m2 hΓ action he
+  obtain ⟨u, h⟩ := uniq hΓ action.sound.hasType.1 he
+  exact h.defeqDF action.sound
+
+/-- …and it also follows from the leaf alone, because the redex of a
+`Pattern.Action` is a constant-headed spine and spine type uniqueness is
+already `LRS.PiPathInv` (:11458).  Hence `LRS.PatStep` is not an additional
+residual: the ladder's consumer direction below costs the leaf and nothing
+more (`LRS.parRedSDefeq_of_piPathInv`). -/
+theorem LRS.PatStep.of_piPathInv [Params.Semantic] (piInv : LRS.PiPathInv) :
+    LRS.PatStep := by
+  intro Γ p r e V A m1 m2 hΓ action he
+  obtain ⟨c, ls', args, heq, _⟩ := action.matched.head_spine
+  subst heq
+  obtain ⟨_, hty⟩ :=
+    LRS.constSpineTypeUniqPath piInv hΓ action.sound.hasType.1 he
+  exact hty.defeqDF action.sound
+
+/-- Congruence of an RHS template under equalities of its captures.  Proved
+structurally from `IsDefEqStrong.app_inv'`: no injectivity, no uniqueness, and
+in particular no `piInv` — the application case transports along the path the
+inverter returns. -/
+theorem applyS_congr [Params.Semantic] {p : Pattern} {Γ : List SExpr}
+    {m1 : List SLevel} {m2 m2' : p.Path → SExpr}
+    (hΓ : Ctx.WF Γ)
+    (hm : ∀ (path : p.Path) (W : SExpr),
+      IsDefEq Γ (m2 path) (m2 path) W → IsDefEq Γ (m2 path) (m2' path) W) :
+    ∀ (r : p.RHS) (V : SExpr), IsDefEq Γ (r.applyS m1 m2) (r.applyS m1 m2) V →
+      IsDefEq Γ (r.applyS m1 m2) (r.applyS m1 m2') V := by
+  intro r
+  induction r with
+  | fixed c hc => exact fun _ hr => hr
+  | var path => exact fun V hr => hm path V hr
+  | app f a ihf iha =>
+    intro V hr
+    simp only [Pattern.RHS.applyS] at hr ⊢
+    obtain ⟨A₀, B₀, w, hfT, haT, P⟩ := (hr.strong hΓ).app_inv' (.inl rfl)
+    exact P.defeqDF (.appDF (ihf _ hfT.defeq) (iha _ haT.defeq))
+
+/-- **Native `ParRed` subject reduction from the leaf.**  Structurally Theory's
+`VEnv.ParRed.defeq` (ChurchRosser, β case), except that every
+`IsDefEq.trans_l` / `uniqU` fixup is replaced by the declared-type path
+returned by the inversion suite.  The only residual inputs are
+`LRS.PiPathInv` — charged exactly once, in the `beta` case — and
+`LRS.PatStep`, itself dischargeable from either (`.of_typeUniq`,
+`.of_piPathInv`).
+
+No Church–Rosser, no standardization, no adequacy: `ShapeLogRel.lean` does not
+import `Theory/Typing/ChurchRosser.lean`, so independence from the Theory CR
+development is module-level rather than merely unreached. -/
+theorem ParRed.defeq_of_piPathInv [Params.Semantic]
+    (piInv : LRS.PiPathInv) (pat : LRS.PatStep) :
+    ∀ {Γ : List SExpr} {e e' : SExpr}, ParRed Γ e e' →
+      ∀ (A : SExpr), Ctx.WF Γ → IsDefEq Γ e e A → IsDefEq Γ e e' A := by
+  intro Γ e e' H
+  induction H with
+  | bvar => exact fun _ _ he => he
+  | sort => exact fun _ _ he => he
+  | const => exact fun _ _ he => he
+  | app _ _ ih1 ih2 =>
+    intro V hΓ he
+    obtain ⟨A₀, B₀, w, hf, ha, P⟩ := (he.strong hΓ).app_inv' (.inl rfl)
+    exact P.defeqDF (.appDF (ih1 _ hΓ hf.defeq) (ih2 _ hΓ ha.defeq))
+  | lam _ _ ih1 ih2 =>
+    intro V hΓ he
+    obtain ⟨B₀, u, v, w, hA, hB, hbody, P⟩ := (he.strong hΓ).lam_inv' (.inl rfl)
+    exact P.defeqDF (.lamDF (ih1 _ hΓ hA.defeq) (ih2 _ ⟨hΓ, u, hA.defeq⟩ hbody.defeq))
+  | forallE _ _ ih1 ih2 =>
+    intro V hΓ he
+    obtain ⟨u, v, w, hA, hB, P⟩ := (he.strong hΓ).forallE_inv_path (.inl rfl)
+    exact P.defeqDF (.forallEDF (ih1 _ hΓ hA.defeq) (ih2 _ ⟨hΓ, u, hA.defeq⟩ hB.defeq))
+  | @beta Adom Γ₂ e₁ e₁' e₂ e₂' _ _ ih1 ih2 =>
+    intro V hΓ he
+    obtain ⟨A₀, B₀, w, hf, ha, P⟩ := (he.strong hΓ).app_inv' (.inl rfl)
+    obtain ⟨B₁, u, v, w', hA, hB₁, hb, Q⟩ := hf.lam_inv' (.inl rfl)
+    -- ↓↓↓ the one and only use of the leaf ↓↓↓
+    obtain ⟨ud, vd, Pdom, Pcod⟩ := piInv hΓ Q
+    obtain ⟨_, Pdom'⟩ := Pdom.symm
+    -- the leaf's *output* is consumed only by `defeqDF` / `subst` on unindexed
+    -- equalities, and only **after** the inductive hypotheses have fired.
+    have hb' := ih1 _ ⟨hΓ, u, hA.defeq⟩ hb.defeq
+    have ha'' := Pdom'.defeqDF (ih2 _ hΓ ha.defeq)
+    have ha' := ha''.hasType.1
+    have main := IsDefEq.trans
+      (.symm (.appDF (.symm (.lamDF hA.defeq hb')) (.symm ha'')))
+      (.beta hb'.hasType.2 ha''.hasType.2)
+    have W : Ctx.SubstEq Γ₂ (.one e₂') (.one e₂) (Adom :: Γ₂) := by
+      refine .cons .nil hA.defeq ?_
+      show IsDefEq Γ₂ e₂' e₂ (SExpr.subst Adom SExpr.Subst.id)
+      rw [SExpr.subst_id]; exact ha''.symm
+    have hconv : IsDefEq Γ₂ (B₁.inst e₂') (B₁.inst e₂) (.sort v) := (hB₁.substCongr W).1
+    have Pcod' : TypeDefEqPath Γ₂ (B₁.inst e₂) (B₀.inst e₂) vd := by
+      simpa only [SExpr.inst] using
+        Pcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar ha')
+    exact (((TypeDefEqPath.single hconv).trans Pcod').trans P).defeqDF main
+  | extra action _ ih =>
+    intro V hΓ he
+    have h1 := pat hΓ action he
+    exact h1.trans (applyS_congr hΓ (fun path W hW => ih path W hΓ hW) _ _ h1.hasType.2)
+
+/-- The `≫*` closure, i.e. the rung `LRS.ParRedSDefeq` itself.  Nothing is
+re-certified along the sequence: the per-step lemma is indexed by no depth. -/
+theorem ParRedS.defeq_of_piPathInv [Params.Semantic]
+    (piInv : LRS.PiPathInv) (pat : LRS.PatStep) : LRS.ParRedSDefeq := by
+  intro Γ e e' A hΓ H he
+  induction H with
+  | rfl => exact he
+  | tail _ h2 ih =>
+    exact ih.trans (ParRed.defeq_of_piPathInv piInv pat h2 _ hΓ ih.hasType.2)
+
+/-- **The consumer statement, with no side conditions.**  The 16C′ leaf pays
+for the CR-ladder rung `LRS.ParRedSDefeq` outright — `LRS.PatStep` is
+discharged from the same input by `LRS.PatStep.of_piPathInv`.  Composed with
+`LRS.SubjectRedS.of_parRedSDefeq` (:15241) this also delivers
+`LRS.SubjectRedS` (which `WHRedS.defeq_of_piPathInv` already gives directly),
+and with `LRS.PiEdgeInv.of_piPathInv` the single-edge rung. -/
+theorem LRS.parRedSDefeq_of_piPathInv [Params.Semantic] (piInv : LRS.PiPathInv) :
+    LRS.ParRedSDefeq :=
+  ParRedS.defeq_of_piPathInv piInv (LRS.PatStep.of_piPathInv piInv)
+
+/-- **HEADLINE (probeR13).**  The CR-ladder rung `LRS.ParRedSDefeq` and the
+L4L-16C′ leaf `LRS.PiPathInv` are *interderivable* modulo the other two rungs.
+Forward is `ParRedS.defeq_of_piPathInv` (native: no Church–Rosser, no
+standardization, no adequacy); backward is `LRS.PiPathInv.of_crLadder_R11`
+(:15543).
+
+Read this in the consumer direction.  As a *producer* route it is closed: the
+rung is not a cheaper input than the leaf, since any proof of it is a proof of
+the leaf.  As a *consumer* it says the ladder comes free with 16C′.  The `pat`
+premise is not an extra cost either — `LRS.PatStep.of_piPathInv` discharges it
+from the leaf, which is why `LRS.parRedSDefeq_of_piPathInv` above needs no
+side conditions. -/
+theorem LRS.piPathInv_iff_parRedSDefeq [Params.Semantic]
+    (pat : LRS.PatStep) (cr : LRS.CRComplete) (std : LRS.PiStandard) :
+    LRS.PiPathInv ↔ LRS.ParRedSDefeq :=
+  ⟨fun piInv => ParRedS.defeq_of_piPathInv piInv pat,
+   fun srp => LRS.PiPathInv.of_crLadder_R11 srp cr std⟩
+
+/-- The single-edge rung from the path-valued leaf: an edge is a one-edge
+path.  The one-liner the R11 notes (:15361, :15579) refer to, now checked. -/
+theorem LRS.PiEdgeInv.of_piPathInv (piInv : LRS.PiPathInv) : LRS.PiEdgeInv :=
+  fun hΓ h => piInv hΓ (.single h)
+
+/-- **The price of the `PiEdgeInv` framing.**  `IsDefEqStrong.lam_inv'` returns
+a *path* — one edge per `defeqDF` in the abstraction's own derivation, and
+adjacent edges may live at different universes — so collapsing it to the
+single edge `LRS.PiEdgeInv` consumes is exactly `TypeDefEqPath.collapse`
+(:10521), i.e. raw type uniqueness.
+
+That is the trade this direction makes, stated plainly: the `PiEdgeInv`
+framing **trades the 16C′ leaf for the L4L-17 co-deliverable**
+(`LogRel.ContextualRawTypeUniq`, :10514) rather than avoiding it.  With
+`LRS.PiEdgeInv.of_piPathInv` above, the two framings are interderivable modulo
+exactly that uniqueness input. -/
+theorem LRS.PiPathInv.of_piEdgeInv_collapse
+    (uniq : LogRel.ContextualRawTypeUniq) (inv : LRS.PiEdgeInv) :
+    LRS.PiPathInv := fun hΓ H => inv hΓ (H.collapse (uniq hΓ))
+
+/-- Vacuity discipline for `LRS.PatStep`.  Its hypothesis set is inhabited
+wherever `Pattern.Action` is — environment-conditional, like
+`LRS.indTyHead_nonvacuous` — and at the action's own type the conclusion is
+`action.sound` itself, so no derivation of `False` is available that does not
+also refute `Pattern.Action.sound`.  The content is entirely the *retyping*
+from `A` to `V`, which is what `.of_typeUniq` and `.of_piPathInv` supply. -/
+theorem LRS.patStep_nonvacuous (pat : LRS.PatStep) {Γ : List SExpr}
+    {p : Pattern} {r : p.RHS × p.Check} {e A : SExpr} {m1 : List SLevel}
+    {m2 : p.Path → SExpr} (hΓ : Ctx.WF Γ)
+    (action : Pattern.Action Γ r e m1 m2 A) :
+    IsDefEq Γ e (r.1.applyS m1 m2) A :=
+  pat hΓ action action.sound.hasType.1
+
+/-! ### Closure records — where the leaf is charged, and three dead routes
+
+Banked from probeR13 Parts 5–7 so that the dead routes are not re-attempted.
+Each entry is a machine-checked statement of a negative result. -/
+
+/-- **The β *congruence* is Π-injectivity-free.**  With the inversion suite in
+hand, `.app (.lam A e₁) e₂ ≡ .app (.lam A e₁') e₂'` is derivable at the
+declared type `V` with **no** `piInv` call at all: the abstraction's own Pi is
+transported to the application's along `Q` by `defeqDF`, which needs no
+inversion.  So the leaf is not charged by the congruence — do not look for it
+there. -/
+theorem beta_congr_no_piInv {Γ : List SExpr} {A A₀ B₀ B₁ e₁ e₁' e₂ e₂' V : SExpr}
+    {u w₁ w₂ : SLevel}
+    (hA : IsDefEq Γ A A (.sort u))
+    (P : TypeDefEqPath Γ (B₀.inst e₂) V w₁)
+    (Q : TypeDefEqPath Γ (.forallE A B₁) (.forallE A₀ B₀) w₂)
+    (rec₁ : IsDefEq (A :: Γ) e₁ e₁' B₁)
+    (rec₂ : IsDefEq Γ e₂ e₂' A₀) :
+    IsDefEq Γ (.app (.lam A e₁) e₂) (.app (.lam A e₁') e₂') V :=
+  P.defeqDF (.appDF (Q.defeqDF (.lamDF hA rec₁)) rec₂)
+
+/-- **…and the *contraction* is where it is charged.**  `IsDefEq.beta` and
+`IsDefEqStrong.beta` both demand the argument at the **abstraction's own**
+domain `A`; the inversion suite supplies it only at the application's domain
+`A₀`.  Reconciling the two is inverting `Q`, and `Q` is a path between two
+syntactic Pis — i.e. `LRS.PiPathInv` verbatim.  This is the whole of the
+residual, isolated. -/
+def LRS.BetaFire : Prop :=
+  ∀ {Γ : List SExpr} {A A₀ B₀ B₁ e e' : SExpr} {w : SLevel},
+    Ctx.WF Γ → TypeDefEqPath Γ (.forallE A B₁) (.forallE A₀ B₀) w →
+    IsDefEq (A :: Γ) e e B₁ → IsDefEq Γ e' e' A₀ →
+    IsDefEq Γ (.app (.lam A e) e') (e.inst e') (B₀.inst e')
+
+theorem LRS.BetaFire.of_piPathInv (piInv : LRS.PiPathInv) : LRS.BetaFire := by
+  intro Γ A A₀ B₀ B₁ e e' w hΓ Q hb ha
+  obtain ⟨ud, vd, Pdom, Pcod⟩ := piInv hΓ Q
+  obtain ⟨_, Pdom'⟩ := Pdom.symm
+  have ha' := Pdom'.defeqDF ha
+  have Pcod' : TypeDefEqPath Γ (B₁.inst e') (B₀.inst e') vd := by
+    simpa only [SExpr.inst] using
+      Pcod.subst (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar ha')
+  exact Pcod'.defeqDF (.beta hb ha')
+
+/-- **The sort restriction does not dodge β.**  A sort-typed β-redex whose
+application domain is *not* the abstraction's own: `A₀` is the redex
+`(fun _ : Sort (l+2) => #0) (Sort (l+1))`, which is `IsDefEq`-equal to
+`Sort (l+1)` but syntactically an `.app`, so no syntactic reconciliation is
+available.  Everything is in the empty context with no environment
+assumptions.
+
+Consequently, restricting a rung to sort-typed subjects removes nothing from
+the β case: sort-typedness constrains the *result* type, never the domain.
+The narrowing is not an escape. -/
+theorem betaSort_domain_unconstrained {l : SLevel} :
+    ∃ A₀ : SExpr, A₀ ≠ .sort l.succ ∧
+      IsDefEq [] (.lam (.sort l.succ) (.bvar 0)) (.lam (.sort l.succ) (.bvar 0))
+        (.forallE A₀ (.sort l.succ)) ∧
+      IsDefEq [] (.sort l) (.sort l) A₀ ∧
+      IsDefEq [] (.app (.lam (.sort l.succ) (.bvar 0)) (.sort l))
+        (.app (.lam (.sort l.succ) (.bvar 0)) (.sort l)) (.sort l.succ) ∧
+      ParRed [] (.app (.lam (.sort l.succ) (.bvar 0)) (.sort l)) (.sort l) := by
+  have hβ : IsDefEq ([] : List SExpr)
+      (.app (.lam (.sort l.succ.succ) (.bvar 0)) (.sort l.succ)) (.sort l.succ)
+      (.sort l.succ.succ) := .beta (.bvar .zero) .sort
+  have hlam : IsDefEq ([] : List SExpr) (.lam (.sort l.succ) (.bvar 0))
+      (.lam (.sort l.succ) (.bvar 0))
+      (.forallE (.sort l.succ) (.sort l.succ)) := .lamDF .sort (.bvar .zero)
+  have hPi := IsDefEq.forallEDF hβ.symm (IsDefEq.sort (l := l.succ))
+  refine ⟨.app (.lam (.sort l.succ.succ) (.bvar 0)) (.sort l.succ), nofun,
+    hPi.defeqDF hlam, hβ.symm.defeqDF .sort,
+    .appDF (hPi.defeqDF hlam) (hβ.symm.defeqDF .sort), .beta .rfl .rfl⟩
+
+/-- Vacuity discipline for `LRS.BetaFire`, at a **non-degenerate** instance:
+the witness of `betaSort_domain_unconstrained`, whose application domain is
+syntactically different from the abstraction's own.  So the Prop is inhabited
+off the diagonal, where all its content is. -/
+theorem LRS.betaFire_nonvacuous (fire : LRS.BetaFire) {l : SLevel} :
+    IsDefEq [] (.app (.lam (.sort l.succ) (.bvar 0)) (.sort l)) (.sort l)
+      (.sort l.succ) := by
+  have hβ : IsDefEq ([] : List SExpr)
+      (.app (.lam (.sort l.succ.succ) (.bvar 0)) (.sort l.succ)) (.sort l.succ)
+      (.sort l.succ.succ) := .beta (.bvar .zero) .sort
+  have hPi := IsDefEq.forallEDF hβ.symm (IsDefEq.sort (l := l.succ))
+  exact fire (Γ := []) (A := .sort l.succ) (B₁ := .sort l.succ)
+    (B₀ := .sort l.succ) (e := .bvar 0) (e' := .sort l)
+    trivial (.single hPi) (.bvar .zero) (hβ.symm.defeqDF .sort)
+
+/-- **The stratification escape, on the consumer side.**  A depth-indexed rung
+would have to be spent once per `≫` link of a `ParRedS` chain, and at link
+`i+1` the walk anchors the call at the *accumulated* `TypeDefEqPath`'s right
+endpoint — a path that carries no stratification data and whose length is
+bounded by nothing in scope.  This is the datum the walk must then manufacture
+at every link. -/
+def LRS.ChainAnchorAt (d : Nat) : Prop :=
+  ∀ {Γ : List SExpr} {A B : SExpr} {u : SLevel},
+    Ctx.WF Γ → TypeDefEqPath Γ A B u → ∃ V c, HasTypeStratifiedS Γ B V c d
+
+/-- **The obstruction.**  The anchor demand *is* a uniform stratification
+bound: every well-typed type in every well-formed context stratified at one
+fixed `d`.  That is exactly probeS's `LRS.PathRestratifyAt.uniformDepthBound`
+— the same fatal proposition, whose truth makes the bootstrap's strong
+induction vacuous. -/
+theorem LRS.ChainAnchorAt.uniformDepthBound {d : Nat} (anc : LRS.ChainAnchorAt d)
+    {Γ : List SExpr} {A : SExpr} {u : SLevel} (hΓ : Ctx.WF Γ)
+    (h : IsDefEq Γ A A (.sort u)) : ∃ V c, HasTypeStratifiedS Γ A V c d :=
+  anc hΓ (.single h)
+
+/-- …and conversely, so there is nothing weaker to aim at: the anchor demand
+and the uniform bound are the same proposition.  Net: the stratification
+escape does not close. -/
+theorem LRS.ChainAnchorAt.of_uniformDepthBound {d : Nat}
+    (bound : ∀ {Γ : List SExpr} {A : SExpr} {u : SLevel}, Ctx.WF Γ →
+      IsDefEq Γ A A (.sort u) → ∃ V c, HasTypeStratifiedS Γ A V c d) :
+    LRS.ChainAnchorAt d := by
+  intro Γ A B u hΓ P
+  obtain ⟨_, h⟩ := P.rightType
+  exact bound hΓ h
+
+/-- Vacuity discipline for `LRS.ChainAnchorAt`: its hypothesis is inhabited in
+the empty context with no environment assumptions, so the Prop is not empty —
+which is what makes the equivalence above a real obstruction rather than a
+vacuous one. -/
+theorem LRS.chainAnchorAt_nonvacuous (anc : LRS.ChainAnchorAt 0) {l : SLevel} :
+    ∃ V c, HasTypeStratifiedS [] (.sort l) V c 0 :=
+  anc trivial (.single (IsDefEq.sort (l := l)))
+
+/-! ## Banking probe R13 — the `RectFrame` bridge at the `indTy` observation
+
+`plans/probes/probeR13-rectframe.lean` established that the frame layer of
+the coherent iota leaf is mechanical *given* a frame that carries the type
+shape alongside the element shape (`LRS.RectFrame` below), and recorded its
+production as a non-additive residual: `LogRel.DefEqRect.mono_l` needs
+`m.HasType a` and `m'.HasType a` for one common `a`, a frame recording only
+`m ≤ m'` can supply neither, and choosing `a` inside the transport is the
+independent re-selection of the type observation the N2 decision forbids —
+so the shape seemed to require threading through every frame *producer*.
+
+The residual dissolves: at a constructor observation the type shape is not
+an independent choice at all.  It is always `WShape.indTy` (`LRS.IndDefEq`
+pairs a `CtorDefEq` with exactly that observation), the shapes an unpaired
+`LRS.CtorFrame` passes through are only `.bot` and `.ctor` forms
+(`WShape.le_ctor` below closes the missing right-hand inversion; the
+existing `WShape.ctor_le` has `ctor` on the left, and
+`WShape.HasType.mono_l` demands antisymmetry), both of those rows of the
+`Shape.hasType` table at `.indTy` are true, and `indTy` is lift-stable
+(`WShape.lift_indTy`) — matching the frame's `lift`/`unlift` moves.  So the
+paired frame is *recoverable* from the unpaired one
+(`LRS.CtorFrame.toRectFrame`), additively, with no producer touched. -/
+
+/-- Right-hand constructor inversion for the shape order: anything below a
+`ctor` shape is `.bot` or a `ctor` form with the same head.  The existing
+`WShape.ctor_le` inverts from the left only; this is the mirror of
+`WShape.le_indTy` one constructor over. -/
+theorem WShape.le_ctor {s : WShape (n+1)} {c : Name} {l : List (WShape n)} {h} :
+    s ≤ .ctor c l h ↔
+      s = .bot ∨ ∃ l' h', s = .ctor c l' h' ∧ List.Forall₂ (· ≤ ·) l' l := by
+  constructor
+  · cases s using WShape.casesOn' with
+    | bot => exact fun _ => .inl rfl
+    | ctor c' l' h' =>
+      intro hle
+      obtain ⟨l'', h'', heq, hf⟩ := WShape.ctor_le.1 hle
+      obtain ⟨rfl, rfl⟩ := WShape.ctor.inj.1 heq
+      exact .inr ⟨l', h', rfl, hf⟩
+    | indTy => apply Not.elim; simp [indTy, ctor, LE.def, Shape.LE.def]
+    | _ => simp only [sort, forallE, lam, ctor, LE.def, Shape.LE.def, false_implies]
+  · rintro (rfl | ⟨l', h', rfl, hf⟩)
+    · exact bot_le
+    · exact WShape.ctor_le.2 ⟨l, h, rfl, hf⟩
+
+/-- info: 'Lean4Lean.SExpr.WShape.le_ctor' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms WShape.le_ctor
+
+/-- `HasType · .indTy` is downward closed along the shape order: below a
+shape typed at `indTy` there are only `.bot` and `.ctor` forms
+(`WShape.le_ctor`), and both rows of the `Shape.hasType` table at `.indTy`
+are true. -/
+theorem WShape.hasType_indTy_of_le {m m' : WShape (n+1)}
+    (hle : m ≤ m') (hm' : m'.HasType .indTy) : m.HasType .indTy := by
+  cases m' using WShape.casesOn' with
+  | bot =>
+    cases WShape.le_bot.1 hle
+    exact WShape.HasType.bot' WShape.HasType.indTy
+  | ctor c l h =>
+    obtain rfl | ⟨l', h', rfl, -⟩ := WShape.le_ctor.1 hle
+    · exact WShape.HasType.bot' WShape.HasType.indTy
+    · exact WShape.HasType.ctor
+  | _ => cases hm'
+
+/-- info: 'Lean4Lean.SExpr.WShape.hasType_indTy_of_le' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms WShape.hasType_indTy_of_le
+
+/-- `HasType · .indTy` is lift-stable, because `indTy` itself is
+(`WShape.lift_indTy`). -/
+theorem WShape.hasType_indTy_lift {n n' : Nat} (le : n ≤ n') {m : WShape (n+1)} :
+    (m.lift (n'+1)).HasType .indTy ↔ m.HasType .indTy := by
+  have h := WShape.HasType.lift (m := m) (a := .indTy) (Nat.succ_le_succ le)
+  rwa [WShape.lift_indTy] at h
+
+/--
+info: 'Lean4Lean.SExpr.WShape.hasType_indTy_lift' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms WShape.hasType_indTy_lift
+
+/-- `LRS.CtorFrame` with the **type** shape threaded alongside the element
+shape, and the `HasType` coherence recorded at each step where the element
+shape moves.  Structurally identical to `LRS.CtorFrame` (same four
+constructors, same level arithmetic); the only difference is that `a` rides
+along instead of being re-chosen. -/
+inductive LRS.RectFrame (Γ : List SExpr) :
+    {n k : Nat} → LogRel Γ n → WShape n → WShape n →
+      LogRel Γ k → WShape k → WShape k → Prop where
+  | refl : RectFrame Γ IH m a IH m a
+  | mono : m ≤ m' → m.HasType a → m'.HasType a →
+      RectFrame Γ IH m' a J p q → RectFrame Γ IH m a J p q
+  | lift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (E : LogRel.LiftEquiv IH IH' le) (hma : m.HasType a) :
+      RectFrame Γ IH m a J p q →
+      RectFrame Γ IH' (m.lift n') (a.lift n') J p q
+  | unlift {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+      (E : LogRel.LiftEquiv IH IH' le) (hma : m.HasType a) :
+      RectFrame Γ IH' (m.lift n') (a.lift n') J p q →
+      RectFrame Γ IH m a J p q
+
+/-- **The frame layer is mechanical.**  Every case is a one-liner against
+machinery that already exists: `LogRel.DefEqRect.mono_l` for `mono` and
+`LogRel.LiftEquiv.rect` (both directions) for `lift`/`unlift`. -/
+theorem LRS.RectFrame.rect {Γ : List SExpr} {n k : Nat}
+    {IH : LogRel Γ n} {m a : WShape n} {J : LogRel Γ k} {p q : WShape k}
+    {M₁ M₂ N₁ N₂ A : SExpr}
+    (F : LRS.RectFrame Γ IH m a J p q)
+    (H : LogRel.DefEqRect J M₁ M₂ N₁ N₂ A p q) :
+    LogRel.DefEqRect IH M₁ M₂ N₁ N₂ A m a := by
+  induction F with
+  | refl => exact H
+  | mono hle hm hm' _ ih => exact (ih H).mono_l hle hm hm'
+  | lift le E hma _ ih => exact (E.rect hma).2 (ih H)
+  | unlift le E hma _ ih => exact (E.rect hma).1 (ih H)
+
+/--
+info: 'Lean4Lean.SExpr.LRS.RectFrame.rect' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.RectFrame.rect
+
+/-- The transported rectangle with both rows flipped, from the same frame. -/
+theorem LRS.RectFrame.symm_rect {Γ : List SExpr} {n k : Nat}
+    {IH : LogRel Γ n} {m a : WShape n} {J : LogRel Γ k} {p q : WShape k}
+    {M₁ M₂ N₁ N₂ A : SExpr}
+    (F : LRS.RectFrame Γ IH m a J p q)
+    (H : LogRel.DefEqRect J M₁ M₂ N₁ N₂ A p q) :
+    LogRel.DefEqRect IH M₂ M₁ N₂ N₁ A m a :=
+  let R := F.rect H
+  ⟨IH.symm R.left, IH.symm R.right,
+    IH.trans (IH.symm R.left) (IH.trans R.cross (IH.symm R.right))⟩
+
+/--
+info: 'Lean4Lean.SExpr.LRS.RectFrame.symm_rect' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.RectFrame.symm_rect
+
+/-- The paired frame composes, so it is a usable index. -/
+theorem LRS.RectFrame.trans {Γ : List SExpr} {n k l : Nat}
+    {IH : LogRel Γ n} {m a : WShape n} {J : LogRel Γ k} {p q : WShape k}
+    {K : LogRel Γ l} {x y : WShape l}
+    (F : LRS.RectFrame Γ IH m a J p q) (G : LRS.RectFrame Γ J p q K x y) :
+    LRS.RectFrame Γ IH m a K x y := by
+  induction F with
+  | refl => exact G
+  | mono hle hm hm' _ ih => exact .mono hle hm hm' (ih G)
+  | lift le E hma _ ih => exact .lift le E hma (ih G)
+  | unlift le E hma _ ih => exact .unlift le E hma (ih G)
+
+/--
+info: 'Lean4Lean.SExpr.LRS.RectFrame.trans' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.RectFrame.trans
+
+/-- Vacuity discipline: `LRS.RectFrame` is inhabited by `refl` at every
+`(IH, m, a)`, which is the frame every native leaf starts from. -/
+theorem LRS.rectFrame_nonvacuous {Γ : List SExpr} {n : Nat}
+    {IH : LogRel Γ n} {m a : WShape n} : LRS.RectFrame Γ IH m a IH m a := .refl
+
+/--
+info: 'Lean4Lean.SExpr.LRS.rectFrame_nonvacuous' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.rectFrame_nonvacuous
+
+/-- The `indTy` observation rides along an unpaired constructor frame: every
+element shape the frame passes through is typed at `indTy` as soon as the
+leaf shape is. -/
+theorem LRS.CtorFrame.hasType_indTy
+    (F : LRS.CtorFrame Γ IH m J p) :
+    p.HasType .indTy → m.HasType .indTy := by
+  induction F with
+  | refl => exact id
+  | mono hle _ ih => exact fun hp => WShape.hasType_indTy_of_le hle (ih hp)
+  | lift le E _ ih => exact fun hp => (WShape.hasType_indTy_lift le).2 (ih hp)
+  | unlift le E _ ih => exact fun hp => (WShape.hasType_indTy_lift le).1 (ih hp)
+
+/--
+info: 'Lean4Lean.SExpr.LRS.CtorFrame.hasType_indTy' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.CtorFrame.hasType_indTy
+
+/-- **The index upgrade is recoverable.**  At a constructor observation the
+type shape is not an independent choice: it is always `indTy`, and an
+unpaired `LRS.CtorFrame` upgrades to the paired `LRS.RectFrame` at
+`a := q := .indTy` with no producer touched.  `mono` recovers both `HasType`
+witnesses from `WShape.hasType_indTy_of_le`; `lift`/`unlift` ride
+`WShape.lift_indTy` through one `LRS` layer via `LogRel.LiftEquiv.succ`. -/
+theorem LRS.CtorFrame.toRectFrame
+    (F : LRS.CtorFrame Γ IH m J p) :
+    p.HasType .indTy →
+      LRS.RectFrame Γ (LRS IH) m .indTy (LRS J) p .indTy := by
+  induction F with
+  | refl => exact fun _ => .refl
+  | mono hle F' ih =>
+    intro hp
+    have hm' := F'.hasType_indTy hp
+    exact .mono hle (WShape.hasType_indTy_of_le hle hm') hm' (ih hp)
+  | lift le E F' ih =>
+    intro hp
+    have h := LRS.RectFrame.lift (Nat.succ_le_succ le) E.succ
+      (F'.hasType_indTy hp) (ih hp)
+    rwa [WShape.lift_indTy] at h
+  | unlift le E F' ih =>
+    intro hp
+    refine LRS.RectFrame.unlift (Nat.succ_le_succ le) E.succ
+      ((WShape.hasType_indTy_lift le).1 (F'.hasType_indTy hp)) ?_
+    rw [WShape.lift_indTy]
+    exact ih hp
+
+/--
+info: 'Lean4Lean.SExpr.LRS.CtorFrame.toRectFrame' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.CtorFrame.toRectFrame
+
+/-- The residual, discharged end-to-end: an unpaired constructor frame
+transports a synchronized rectangle at the `indTy` observation. -/
+theorem LRS.CtorFrame.rect
+    (F : LRS.CtorFrame Γ IH m J p) (hp : p.HasType .indTy)
+    {M₁ M₂ N₁ N₂ A : SExpr}
+    (H : LogRel.DefEqRect (LRS J) M₁ M₂ N₁ N₂ A p .indTy) :
+    LogRel.DefEqRect (LRS IH) M₁ M₂ N₁ N₂ A m .indTy :=
+  (F.toRectFrame hp).rect H
+
+/--
+info: 'Lean4Lean.SExpr.LRS.CtorFrame.rect' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms LRS.CtorFrame.rect
diff --git a/Lean4Lean/Experimental/ShapeLogRelAdequacy.lean b/Lean4Lean/Experimental/ShapeLogRelAdequacy.lean
index 1bda2041..f2c1bfeb 100644
--- a/Lean4Lean/Experimental/ShapeLogRelAdequacy.lean
+++ b/Lean4Lean/Experimental/ShapeLogRelAdequacy.lean
@@ -1,9 +1,10 @@
 import Lean4Lean.Experimental.ShapeLogRel
+import Lean4Lean.Theory.Typing.Strong
 
 namespace Lean4Lean
 
 namespace SExpr
-variable [Params]
+variable [Params] [Params.Semantic]
 
 def LR.Adequate (Γ₀ Γ : List SExpr) (ρ : Valuation) (M N A : SExpr) (m a : WShape n) :=
   (∀ {{σ σ'}}, LR.SubstWF Γ₀ σ σ' Γ ρ →
@@ -11,102 +12,7916 @@ def LR.Adequate (Γ₀ Γ : List SExpr) (ρ : Valuation) (M N A : SExpr) (m a :
     (LR Γ₀).DefEq (N.subst σ) (N.subst σ') (A.subst σ) m a) ∧
   ∀ {{σ}}, LR.SubstWF Γ₀ σ σ Γ ρ → (LR Γ₀).DefEq (M.subst σ) (N.subst σ) (A.subst σ) m a
 
+/-- Adequacy specialized to one shape level.  Naming the indexed statement
+separately makes the dependency of the joint adequacy/uniqueness
+construction explicit: inversion at level `n + 1` can consume this package
+without assuming the final polymorphic adequacy theorem. -/
+def LR.AdequacyAt (Γ₀ : List SExpr) (n : Nat) : Prop :=
+  ∀ {Γ : List SExpr} {ρ : Valuation} {M N A : SExpr} {m a : WShape n},
+    IsDefEqStrong Γ M N A →
+    LE_Interp ρ m.T M → LE_Interp ρ a.T A → m.HasType a →
+    LR.Adequate Γ₀ Γ ρ M N A m a
+
+/-- Adequacy observed at one explicit stratified typing depth of its left
+endpoint.  Shape levels remain polymorphic: semantic application chooses
+them freely.  This is sufficient for bounded sort/Pi observations, but an
+arbitrary left-endpoint certificate does not by itself bound every premise
+of the accompanying strong equality; a coherent derivation certificate is
+still required by the eventual adequacy induction rung. -/
+def LR.AdequacyAtDepth (Γ₀ : List SExpr) (depth : Nat) : Prop :=
+  ∀ {n : Nat} {Γ : List SExpr} {ρ : Valuation} {M N A B : SExpr}
+      {core : Bool} {m a : WShape n},
+    IsDefEqStrong Γ M N A →
+    HasTypeStratifiedS Γ M B core depth →
+    LE_Interp ρ m.T M → LE_Interp ρ a.T A → m.HasType a →
+    LR.Adequate Γ₀ Γ ρ M N A m a
+
+/-- Depth-bounded adequacy uniformly over well-formed target contexts. -/
+def LR.ContextualAdequacyAtDepth (depth : Nat) : Prop :=
+  ∀ {Γ₀ : List SExpr}, Ctx.WF Γ₀ → LR.AdequacyAtDepth Γ₀ depth
+
+/-- Adequacy at one shape level, uniformly over well-formed target contexts.
+The contextual quantifier is part of the induction unit: Pi uniqueness enters
+an extended target context and therefore cannot be recovered from a package
+fixed at the outer `Γ₀`. -/
+def LR.ContextualAdequacyAt (n : Nat) : Prop :=
+  ∀ {Γ₀ : List SExpr}, Ctx.WF Γ₀ → LR.AdequacyAt Γ₀ n
+
+/-- Limited uniqueness at one shape level in every well-formed target
+context. -/
+def LogRel.ContextualLimitedUniq (n : Nat) : Prop :=
+  ∀ {Γ : List SExpr}, Ctx.WF Γ →
+    LogRel.LimitedUniq (LR Γ : LogRel Γ n)
+
+/-- The exact successor lambda-retyping obligation, contextual because its
+codomain branch is checked below a binder.  Unlike arbitrary Pi-observation
+alignment, this term-indexed property is precisely what
+`LRS.limitedUniq_of_typeUniq` consumes. -/
+def LogRel.ContextualLamRetype (n : Nat) : Prop :=
+  ∀ {Γ : List SExpr}, Ctx.WF Γ →
+    LogRel.LimitedUniq.LamRetype (LR Γ : LogRel Γ n)
+
+/-! #### Path-level positive bootstrap
+
+The adequacy Pi observation deliberately retains heterogeneous type
+equalities as `TypeDefEqPath`: adjacent edges can assign different universes
+to their shared endpoint.  Collapsing those paths by assuming raw uniqueness
+would make the level-zero bootstrap circular.  Instead, positive adequacy
+transports a non-bottom sort or Pi observation across the whole path.  This
+first proves path-level sort/Pi inversion, then stratified path uniqueness,
+and only then collapses paths to ordinary weak equalities. -/
+
+/-- Observe both endpoints of one strong equality at a fixed non-bottom sort
+shape.  `LE_Interp.sound` supplies the declared type shape required by
+adequacy, including when the displayed type is not syntactically a sort. -/
+theorem IsDefEqStrong.sort_observe_of_adequacy
+    {Γ : List SExpr} {X Y V : SExpr} {u : SLevel}
+    (adequacy : LR.AdequacyAt Γ 1)
+    (d : IsDefEqStrong Γ X Y V)
+    (hX : LE_Interp .nil
+      (WShape.T (n := 1) (.sort (decide (u ≠ .zero)))) X) :
+    LE_Interp .nil
+        (WShape.T (n := 1) (.sort (decide (u ≠ .zero)))) Y ∧
+      ∃ w, Γ ⊢ X ⤳* .sort w ∧ Γ ⊢ Y ⤳* .sort w := by
+  have hY := (LE_Interp.sound d .nil).1.1 hX
+  have ⟨n, mX, mV, h1, h2, h3, hV, h5⟩ :=
+    (LE_Interp.sound d .nil).2 hX |>.out
+  have h2' := WShape.lift_sort ▸ (TShape.LE.lift_l h1).1 h2
+  dsimp only at h2'
+  cases WShape.sort_le.1 h2'
+  cases show mV = (.sort true : WShape 1).lift n by
+    let _ + 1 := n
+    simp only [WShape.HasType, WShape.sort] at h5
+    ext1
+    generalize mV.val = mv at h5
+    let .sort := Shape.HasType.unfold_iff.1 h5
+    rfl
+  have h1' : 1 ≤ n := h1
+  have hrel := adequacy d hX (hV.unlift h1') .sort
+  have hrel' := hrel.2 (.id)
+  refine ⟨hY, ?_⟩
+  exact (LR Γ).sort_iff.1
+    (subst_id ▸ subst_id ▸ subst_id ▸ hrel')
+
+/-- A heterogeneous type path between two syntactic sorts preserves their
+exact universe level.  The semantic observation is propagated edge by edge;
+weak-head determinism joins the exact sort exposed by adjacent edges. -/
+theorem TypeDefEqPath.sort_inv_of_adequacy
+    {Γ : List SExpr} {u v s : SLevel}
+    (adequacy : LR.AdequacyAt Γ 1)
+    (hΓ : Ctx.WF Γ)
+    (H : TypeDefEqPath Γ (.sort u) (.sort v) s) : u = v := by
+  let m : WShape 1 := .sort (decide (u ≠ .zero))
+  have hstart : LE_Interp .nil m.T (.sort u) :=
+    .sort TShape.sort_eqv.1
+  have go : ∀ {X Y t}, TypeDefEqPath Γ X Y t →
+      LE_Interp .nil m.T X → WHRedS Γ X (.sort u) →
+      LE_Interp .nil m.T Y ∧ WHRedS Γ Y (.sort u) := by
+    intro X Y t P
+    induction P with
+    | single h =>
+      intro hX hred
+      obtain ⟨hY, w, hredX, hredY⟩ :=
+        h.strong hΓ |>.sort_observe_of_adequacy adequacy hX
+      have hsort := hred.determ_l hredX .sort
+      cases WHNF.sort.whRedS hsort
+      exact ⟨hY, hredY⟩
+    | trans _ _ ih₁ ih₂ =>
+      intro hX hred
+      obtain ⟨hY, hredY⟩ := ih₁ hX hred
+      exact ih₂ hY hredY
+  obtain ⟨_, hfinal⟩ := go H hstart .rfl
+  cases WHNF.sort.whRedS hfinal
+  rfl
+
+/-- Observe both endpoints of one strong equality at the bottom-domain Pi
+shape.  The successor type relation exposes their Pi weak-head forms and the
+path-valued domain/codomain alignment without any uniqueness assumption. -/
+theorem IsDefEqStrong.forallE_observe_of_adequacy
+    {Γ : List SExpr} {X Y : SExpr} {s : SLevel}
+    (adequacy : LR.AdequacyAt Γ 1)
+    (d : IsDefEqStrong Γ X Y (.sort s))
+    (hX : LE_Interp .nil
+      (WShape.T (n := 1)
+        (.forallE (.bot : WShape 0) WShapeFun.bot)) X) :
+    LE_Interp .nil
+        (WShape.T (n := 1)
+          (.forallE (.bot : WShape 0) WShapeFun.bot)) Y ∧
+      ∃ BX FX BY FY u v,
+        Γ ⊢ X ⤳* .forallE BX FX ∧
+        Γ ⊢ Y ⤳* .forallE BY FY ∧
+        TypeDefEqPath Γ BX BY u ∧
+        TypeDefEqPath (BX :: Γ) FX FY v := by
+  have hY := (LE_Interp.sound d .nil).1.1 hX
+  have hmem : WShape.HasType (n := 1)
+      (.forallE (.bot : WShape 0) WShapeFun.bot)
+      (.sort (s ≠ .zero)) := by
+    refine WShape.HasType.forallE_l.2 ⟨_, ?_, rfl⟩
+    refine WShape.HasTypePi.iff.2 ⟨.bot (.bot' .sort), fun x hx => ?_⟩
+    cases WShape.HasType.bot_r hx
+    exact WShapeFun.bot_app.symm ▸ .bot .sort
+  have hA : LE_Interp .nil
+      (WShape.T (n := 1) (.sort (s ≠ .zero))) (.sort s) :=
+    .sort TShape.sort_eqv.1
+  have hrel := (adequacy d hX hA hmem).2 (.id)
+  refine ⟨hY, ?_⟩
+  have hrel' := subst_id ▸ subst_id ▸ subst_id ▸ hrel
+  change LRS.TyDefEq (LR0 (Γ := Γ)) X Y
+    (.forallE (.bot : WShape 0) WShapeFun.bot) at hrel'
+  obtain ⟨BX, FX, BY, FY, u, v, hredX, hredY, hdom, hcod, _⟩ := hrel'
+  exact ⟨BX, FX, BY, FY, u, v, hredX, hredY, hdom, hcod⟩
+
+/-- Pi injectivity for an entire heterogeneous type path.  At a path
+junction the next codomain path is transported back through the accumulated
+domain path one ordinary edge at a time. -/
+theorem TypeDefEqPath.forallE_inv_of_adequacy
+    {Γ : List SExpr} {A B A' B' : SExpr} {s : SLevel}
+    (adequacy : LR.AdequacyAt Γ 1)
+    (hΓ : Ctx.WF Γ)
+    (H : TypeDefEqPath Γ (.forallE A B) (.forallE A' B') s) :
+    ∃ u v, TypeDefEqPath Γ A A' u ∧
+      TypeDefEqPath (A :: Γ) B B' v := by
+  let p : WShape 1 := .forallE (.bot : WShape 0) WShapeFun.bot
+  have hstart : LE_Interp .nil p.T (.forallE A B) := by
+    refine .forallE' .bot .bot (.bot <| .bot' .sort) fun _ h => ?_
+    cases h.bot_r
+    exact WShapeFun.bot_app.symm ▸ .bot
+  have go : ∀ {X Y t A B}, TypeDefEqPath Γ X Y t →
+      LE_Interp .nil p.T X → WHRedS Γ X (.forallE A B) →
+      LE_Interp .nil p.T Y ∧
+        ∃ AY BY u v, WHRedS Γ Y (.forallE AY BY) ∧
+          TypeDefEqPath Γ A AY u ∧
+          TypeDefEqPath (A :: Γ) B BY v := by
+    intro X Y t A B P
+    induction P generalizing A B with
+    | single h =>
+      intro hX hred
+      obtain ⟨hY, BX, FX, BY, FY, u, v,
+          hredX, hredY, hdom, hcod⟩ :=
+        h.strong hΓ |>.forallE_observe_of_adequacy adequacy hX
+      cases hred.determ .forallE hredX .forallE
+      exact ⟨hY, BY, FY, u, v, hredY, hdom, hcod⟩
+    | trans _ _ ih₁ ih₂ =>
+      intro hX hred
+      obtain ⟨hY, AY, BY, u₁, v₁, hredY, hdom₁, hcod₁⟩ :=
+        ih₁ hX hred
+      obtain ⟨hZ, AZ, BZ, u₂, v₂, hredZ, hdom₂, hcod₂⟩ :=
+        ih₂ hY hredY
+      obtain ⟨_, hdom₁'⟩ := hdom₁.symm
+      have hcod₂' := hdom₁'.defeqDF_l_path hcod₂
+      exact ⟨hZ, AZ, BZ, u₁, v₁, hredZ,
+        .trans hdom₁ hdom₂, .trans hcod₁ hcod₂'⟩
+  obtain ⟨_, AX, BX, u, v, hfinal, hdom, hcod⟩ :=
+    go H hstart .rfl
+  cases WHNF.forallE.whRedS hfinal
+  exact ⟨u, v, hdom, hcod⟩
+
+/-- Lift a codomain path through a fixed Pi domain. -/
+theorem TypeDefEqPath.forallE_right
+    (hA : IsDefEq Γ A A (.sort u))
+    (H : TypeDefEqPath (A :: Γ) B C v) :
+    TypeDefEqPath Γ (.forallE A B) (.forallE A C) (.imax u v) := by
+  induction H with
+  | single h => exact .single (.forallEDF hA h)
+  | trans _ _ ih₁ ih₂ => exact .trans ih₁ ih₂
+
+/-- The path-valued inversion package obtained before heterogeneous paths are
+collapsed.  Endpoint stratifications may initially name different universe
+levels; `sortPathInv` aligns them without raw uniqueness. -/
+structure JointStratifiedPathInversion : Prop where
+  sortPathInv : ∀ {Γ : List SExpr} {u v s : SLevel},
+    Ctx.WF Γ → TypeDefEqPath Γ (.sort u) (.sort v) s → u = v
+  forallEInv : ∀ {Γ : List SExpr} {A B A' B' V V' : SExpr}
+      {s : SLevel} {n n' : Nat},
+    Ctx.WF Γ →
+    TypeDefEqPath Γ (.forallE A B) (.forallE A' B') s →
+    HasTypeStratifiedS Γ (.forallE A B) V true n →
+    HasTypeStratifiedS Γ (.forallE A' B') V' true n' →
+    (∃ up uL uR, TypeDefEqPath Γ A A' up ∧
+      HasTypeStratifiedS Γ A (.sort uL) true (n - 1) ∧
+      HasTypeStratifiedS Γ A' (.sort uR) true (n' - 1)) ∧
+    ∃ vp vL vR, TypeDefEqPath (A :: Γ) B B' vp ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort vL) true (n - 1) ∧
+      HasTypeStratifiedS (A' :: Γ) B' (.sort vR) true (n' - 1)
+
+/-- Positive adequacy supplies path-valued sort/Pi inversion directly. -/
+theorem JointStratifiedPathInversion.of_adequacy
+    (adequacy : LR.ContextualAdequacyAt 1) :
+    JointStratifiedPathInversion where
+  sortPathInv hΓ H := H.sort_inv_of_adequacy (adequacy hΓ) hΓ
+  forallEInv := by
+    intro Γ A B A' B' V V' s n n' hΓ h hL hR
+    obtain ⟨uL, vL, hAL, hBL⟩ := hL.forallE_inv
+    obtain ⟨uR, vR, hAR, hBR⟩ := hR.forallE_inv
+    obtain ⟨up, vp, hAA, hBB⟩ :=
+      TypeDefEqPath.forallE_inv_of_adequacy (adequacy hΓ) hΓ h
+    exact ⟨⟨up, uL, uR, hAA, hAL, hAR⟩,
+      vp, vL, vR, hBB, hBL, hBR⟩
+
+/-- Positive adequacy supplies the residual of the repaired chain wall.
+
+`LRS.PiPathInv` (SLR) is exactly `TypeDefEqPath.forallE_inv_of_adequacy`
+above, packaged contextually.  Nothing is added in the packaging: that
+theorem already requests no stratification certificate, which is why the
+constructor-spine discipline it discharges carries no depth index either. -/
+theorem LRS.PiPathInv.of_adequacy (adequacy : LR.ContextualAdequacyAt 1) :
+    LRS.PiPathInv := fun hΓ H =>
+  TypeDefEqPath.forallE_inv_of_adequacy (adequacy hΓ) hΓ H
+
+/-- Faithfulness certificate: the path-valued inversion package the tree
+already builds implies the residual, so this is a weakening rather than a
+restatement.  The endpoint stratifications that `forallEInv` demands are
+recovered from the path's own two self-typings — retaining the path is what
+makes the narrower statement sufficient. -/
+theorem LRS.PiPathInv.of_jointStratifiedPathInversion
+    (inv : JointStratifiedPathInversion) : LRS.PiPathInv := by
+  intro Γ A B A' B' s hΓ H
+  obtain ⟨n₁, h₁, _⟩ := (H.leftType.strong hΓ).stratify
+  obtain ⟨_, H'⟩ := H.right
+  obtain ⟨n₂, h₂, _⟩ := (H'.leftType.strong hΓ).stratify
+  obtain ⟨⟨up, _, _, hdom, _, _⟩, vp, _, _, hcod, _, _⟩ :=
+    inv.forallEInv hΓ H h₁ h₂
+  exact ⟨up, vp, hdom, hcod⟩
+
+/-- Weak type uniqueness with a heterogeneous path as its result.
+
+This is the acyclic form of the stratified proof: path-level Pi inversion is
+already available from positive adequacy, while every recursive comparison
+of two sort indices is resolved by `sortPathInv`. -/
+theorem IsDefEq.uniqPath_of_stratified_inversion
+    (inv : JointStratifiedPathInversion) (hΓ : Ctx.WF Γ)
+    (h1 : IsDefEq Γ e₁ e₂ A) (h2 : IsDefEq Γ e₂ e₃ B) :
+    ∃ u, TypeDefEqPath Γ A B u := by
+  suffices ∀ {e A B b n₁ n₂ n}, n₁ ≤ n → n₂ ≤ n →
+      HasTypeStratifiedS Γ e A b n₁ →
+      HasTypeStratifiedS Γ e B b n₂ →
+      ∃ up uA uB, TypeDefEqPath Γ A B up ∧
+        HasTypeStratifiedS Γ A (.sort uA) true (n - 1) ∧
+        HasTypeStratifiedS Γ B (.sort uB) true (n - 1) by
+    obtain ⟨n₁, _, h1A⟩ := (h1.strong hΓ).stratify
+    obtain ⟨n₂, h2B, _⟩ := (h2.strong hΓ).stratify
+    obtain ⟨u, _, _, h, _⟩ :=
+      this (Nat.le_max_left ..) (Nat.le_max_right ..) h1A h2B
+    exact ⟨u, h⟩
+  clear h1 h2
+  intro e A B b n₁ n₂ n le₁ le₂ H1
+  induction n using WellFounded.induction Nat.lt_wfRel.2
+    generalizing n₁ n₂ Γ e A B b with
+  | _ n IH =>
+  induction H1 generalizing B n₂ n with
+  | bvar a1 a2 =>
+    intro (.bvar b1 b2)
+    cases a1.uniq b1
+    exact ⟨_, _, _, .single b2.hasType,
+      b2.mono (Nat.sub_le_sub_right le₂ 1),
+      b2.mono (Nat.sub_le_sub_right le₂ 1)⟩
+  | sort' =>
+    intro (.sort')
+    exact ⟨_, _, _, .single .sort, .base .sort', .base .sort'⟩
+  | const a1 a2 a3 =>
+    intro (.const b1 b2 b3)
+    cases a1.symm.trans b1
+    replace le₁ := Nat.sub_le_sub_right le₁ 1
+    exact ⟨_, _, _, .single a3.hasType, a3.mono le₁, a3.mono le₁⟩
+  | app a1 a2 a3 a4 a5 ih1 ih2 ih3 ih4 ih5 =>
+    intro (.app b1 b2 b3 b4 b5)
+    have ⟨_, _, _, c1, c3, c4⟩ :=
+      ih3 n IH hΓ (Nat.le_of_succ_le le₁) (Nat.le_of_succ_le le₂) b3
+    have ⟨⟨_, _, _, d1, d2, d2'⟩,
+        _, _, _, d3, d4, d5⟩ :=
+      inv.forallEInv hΓ c1 c3 c4
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have hΓA : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have d4n := d4.mono (n := n) (by omega)
+    have ⟨_, _, _, e1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₁ (Nat.le_refl _) a2 d4n
+    have ev1 := inv.sortPathInv hΓA e1
+    cases ev1
+    have hΓB : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, b1.hasType⟩⟩
+    have d5n := d5.mono (n := n) (by omega)
+    have ⟨_, _, _, e2, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓB le₂ (Nat.le_refl _) b2 d5n
+    have ev2 := inv.sortPathInv hΓB e2
+    cases ev2
+    have hinst := d3.subst
+      (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar a4.hasType)
+    have hleft := a5.mono le₁
+    have hright := b5.mono le₂
+    exact ⟨_, _, _, by simpa only [SExpr.inst] using hinst, hleft, hright⟩
+  | lam a1 a2 a3 a4 ih1 ih2 ih3 ih4 =>
+    intro (.lam b1 b2 b3 b4)
+    have hΓA : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have ⟨_, _, _, c1, c3, c4⟩ := ih3 n IH hΓA
+      (Nat.le_of_succ_le le₁) (Nat.le_of_succ_le le₂) b3
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have ⟨_, _, _, d1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ le₁ le₂ a1 b1
+    have eu := inv.sortPathInv hΓ d1
+    cases eu
+    have ⟨_, _, _, d2, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₁ (Nat.le_refl _) a2 c3
+    have ev1 := inv.sortPathInv hΓA d2
+    cases ev1
+    have ⟨_, _, _, d3, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₂ (Nat.le_refl _) b2 c4
+    have ev2 := inv.sortPathInv hΓA d3
+    cases ev2
+    exact ⟨_, _, _, c1.forallE_right a1.hasType,
+      a4.mono le₁, b4.mono le₂⟩
+  | forallE a1 a2 ih1 ih2 =>
+    intro (.forallE b1 b2)
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have ⟨_, _, _, hA, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ le₁ le₂ a1 b1
+    have eu := inv.sortPathInv hΓ hA
+    cases eu
+    have hΓ' : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have ⟨_, _, _, hB, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ' le₁ le₂ a2 b2
+    have ev := inv.sortPathInv hΓ' hB
+    cases ev
+    exact ⟨_, _, _, .single .sort, .base .sort', .base .sort'⟩
+  | @base Γ e A n₁ a1 ih =>
+    intro H2
+    replace ih {n'} le :=
+      @ih n' (fun y hlt => IH y (Nat.lt_of_lt_of_le hlt le)) hΓ
+    generalize eq : true = b at H2
+    induction H2 with cases eq
+    | base b1 _ => exact ih (Nat.le_refl _) le₁ le₂ b1
+    | defeq bEq bA bB be ihA' ihB' ihe' =>
+      have ⟨_, _, _, c1, c3, c4⟩ :=
+        ihe' a1 hΓ (Nat.le_of_succ_le le₂) ih rfl
+      let n + 1 := n
+      replace le₂ := Nat.le_of_succ_le_succ le₂
+      have ⟨_, _, _, d1, _, _⟩ :=
+        IH _ (Nat.lt_succ_self _) hΓ le₂ (Nat.le_refl _) bA c4
+      have eu := inv.sortPathInv hΓ d1
+      cases eu
+      exact ⟨_, _, _, .trans c1 (.single bEq.defeq), c3, bB.mono le₂⟩
+  | defeq hEq hA hB he ihA ihB ihe =>
+    intro H2
+    have ⟨_, _, _, c1, c3, c4⟩ :=
+      ihe n IH hΓ (Nat.le_of_succ_le le₁) le₂ H2
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    have ⟨_, _, _, d1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ le₁ (Nat.le_refl _) hA c3
+    have eu := inv.sortPathInv hΓ d1
+    cases eu
+    exact ⟨_, _, _, .trans (.single hEq.defeq.symm) c1,
+      hB.mono le₁, c4⟩
+
+/-- Collapse a heterogeneous type path after deriving the universe alignment
+at every junction from path-level stratified uniqueness. -/
+theorem TypeDefEqPath.collapse_of_stratified_inversion
+    (inv : JointStratifiedPathInversion) (hΓ : Ctx.WF Γ)
+    (H : TypeDefEqPath Γ A B u) : IsDefEq Γ A B (.sort u) := by
+  induction H with
+  | single h => exact h
+  | trans _ _ ih₁ ih₂ =>
+    obtain ⟨_, huv⟩ :=
+      IsDefEq.uniqPath_of_stratified_inversion
+        inv hΓ ih₁.hasType.2 ih₂.hasType.1
+    have huv' := inv.sortPathInv hΓ huv
+    cases huv'
+    exact ih₁.trans ih₂
+
+/-- Positive level-one adequacy is sufficient to derive contextual raw weak
+type uniqueness; no raw-uniqueness premise occurs in the construction. -/
+theorem LogRel.contextualRawTypeUniq_of_adequacy
+    (adequacy : LR.ContextualAdequacyAt 1) :
+    LogRel.ContextualRawTypeUniq := by
+  let inv := JointStratifiedPathInversion.of_adequacy adequacy
+  intro Γ hΓ x A B hxA hxB
+  obtain ⟨u, hAB⟩ :=
+    IsDefEq.uniqPath_of_stratified_inversion inv hΓ hxA hxB
+  exact ⟨u, hAB.collapse_of_stratified_inversion inv hΓ⟩
+
+/-- The two syntactic inversion facts needed by stratified weak type
+uniqueness.  Keeping the package independent of adequacy makes the
+well-founded boundary explicit: the semantic construction supplies these
+observations, while the theorem below consumes only their statements. -/
+structure JointStratifiedInversion : Prop where
+  sortInv : ∀ {Γ : List SExpr} {u v : SLevel} {V : SExpr},
+    Ctx.WF Γ → IsDefEqStrong Γ (.sort u) (.sort v) V → u = v
+  forallEInv : ∀ {Γ : List SExpr} {A B A' B' V V' : SExpr}
+      {s : SLevel} {n n' : Nat},
+    Ctx.WF Γ →
+    IsDefEqStrong Γ (.forallE A B) (.forallE A' B') (.sort s) →
+    HasTypeStratifiedS Γ (.forallE A B) V true n →
+    HasTypeStratifiedS Γ (.forallE A' B') V' true n' →
+    (∃ u, IsDefEq Γ A A' (.sort u) ∧
+      HasTypeStratifiedS Γ A (.sort u) true (n - 1)) ∧
+    ∃ v, IsDefEq (A :: Γ) B B' (.sort v) ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort v) true (n - 1) ∧
+      HasTypeStratifiedS (A' :: Γ) B' (.sort v) true (n' - 1)
+
+/-- Restriction interface for ordinary stratified inversion up to one typing
+depth.  Every use records the depths of the endpoint stratifications
+explicitly.  Bounded adequacy directly constructs only the path-valued
+package below; no bounded path-collapse constructor for this stronger
+interface is claimed. -/
+structure JointStratifiedInversionAt (depth : Nat) : Prop where
+  sortInv : ∀ {Γ : List SExpr} {u v : SLevel} {V : SExpr} {d : Nat},
+    d ≤ depth → Ctx.WF Γ →
+    IsDefEqStrong Γ (.sort u) (.sort v) V →
+    HasTypeStratifiedS Γ (.sort u) V true d →
+    u = v
+  forallEInv : ∀ {Γ : List SExpr} {A B A' B' V V' : SExpr}
+      {s : SLevel} {n n' : Nat},
+    n ≤ depth → n' ≤ depth → Ctx.WF Γ →
+    IsDefEqStrong Γ (.forallE A B) (.forallE A' B') (.sort s) →
+    HasTypeStratifiedS Γ (.forallE A B) V true n →
+    HasTypeStratifiedS Γ (.forallE A' B') V' true n' →
+    (∃ u, IsDefEq Γ A A' (.sort u) ∧
+      HasTypeStratifiedS Γ A (.sort u) true (n - 1)) ∧
+    ∃ v, IsDefEq (A :: Γ) B B' (.sort v) ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort v) true (n - 1) ∧
+      HasTypeStratifiedS (A' :: Γ) B' (.sort v) true (n' - 1)
+
+/-- The non-collapsed depth rung obtained directly from bounded adequacy.
+The endpoint depth certificates are retained alongside each path, so the
+subsequent path-collapse proof can recurse strictly below the two Pi
+typings instead of appealing to global raw uniqueness. -/
+structure JointStratifiedPathInversionAt (depth : Nat) : Prop where
+  sortInv : ∀ {Γ : List SExpr} {u v : SLevel} {V B : SExpr}
+      {core : Bool} {d : Nat},
+    d ≤ depth → Ctx.WF Γ →
+    IsDefEqStrong Γ (.sort u) (.sort v) V →
+    HasTypeStratifiedS Γ (.sort u) B core d →
+    u = v
+  forallEInv : ∀ {Γ : List SExpr} {A B A' B' V V' : SExpr}
+      {s : SLevel} {n n' : Nat},
+    n ≤ depth → n' ≤ depth → Ctx.WF Γ →
+    IsDefEqStrong Γ (.forallE A B) (.forallE A' B') (.sort s) →
+    HasTypeStratifiedS Γ (.forallE A B) V true n →
+    HasTypeStratifiedS Γ (.forallE A' B') V' true n' →
+    (∃ up uL uR, TypeDefEqPath Γ A A' up ∧
+      HasTypeStratifiedS Γ A (.sort uL) true (n - 1) ∧
+      HasTypeStratifiedS Γ A' (.sort uR) true (n' - 1)) ∧
+    ∃ vp vL vR, TypeDefEqPath (A :: Γ) B B' vp ∧
+      HasTypeStratifiedS (A :: Γ) B (.sort vL) true (n - 1) ∧
+      HasTypeStratifiedS (A' :: Γ) B' (.sort vR) true (n' - 1)
+
+/-- Restrict an already-complete inversion package to a finite depth. -/
+theorem JointStratifiedInversion.at
+    (inv : JointStratifiedInversion) (depth : Nat) :
+    JointStratifiedInversionAt depth where
+  sortInv _ hΓ h _ := inv.sortInv hΓ h
+  forallEInv _ _ hΓ h hL hR := inv.forallEInv hΓ h hL hR
+
+/-- A depth-bounded adequacy rung already determines the universe of a sort
+observation at that same typing depth.  No inversion or uniqueness package
+is consumed here. -/
+theorem IsDefEqStrong.sort_inv_of_adequacyAtDepth
+    {Γ : List SExpr} {u v : SLevel} {V B : SExpr} {core : Bool}
+    {depth : Nat}
+    (adequacy : LR.AdequacyAtDepth Γ depth)
+    (d : IsDefEqStrong Γ (.sort u) (.sort v) V)
+    (hstrat : HasTypeStratifiedS Γ (.sort u) B core depth) :
+    u = v := by
+  let m : WShape 1 := .sort (decide (u ≠ .zero))
+  have hM : LE_Interp .nil m.T (.sort u) :=
+    .sort TShape.sort_eqv.1
+  obtain ⟨n, mU, mV, hlevel, hterm, htype, hV, htyped⟩ :=
+    (LE_Interp.sound d .nil).2 hM |>.out
+  have hterm' := WShape.lift_sort ▸ (TShape.LE.lift_l hlevel).1 hterm
+  dsimp only at hterm'
+  cases WShape.sort_le.1 hterm'
+  cases show mV = (.sort true : WShape 1).lift n by
+    let _ + 1 := n
+    simp only [WShape.HasType, WShape.sort] at htyped
+    ext1
+    generalize mV.val = mv at htyped
+    let .sort := Shape.HasType.unfold_iff.1 htyped
+    rfl
+  have hlevel' : 1 ≤ n := hlevel
+  have hrel := (adequacy d hstrat hM (hV.unlift hlevel') .sort).2 .id
+  obtain ⟨w, hu, hv⟩ :=
+    (LR Γ).sort_iff.1 (subst_id ▸ subst_id ▸ subst_id ▸ hrel)
+  cases WHNF.sort.whRedS hu
+  cases WHNF.sort.whRedS hv
+  rfl
+
+/-! #### The §4.4 shape facts, and the rung each one costs
+
+Ported from `plans/probes/probeW-disjointness.lean`.  The definitions and the
+three soundness-derived facts live in `ShapeLogRel.lean` — they are statements
+about `LE_Interp`, not about adequacy.  What is *here* is the depth ledger:
+which rung, if any, each fact charges.
+
+The answer is that **three of the four charge nothing** and the fourth charges
+**depth 0**.  `LRS.SortInv` is the only one that needs a rung, because
+`WShape.sort` records only `decide (u ≠ .zero)` (`LRS.sortInv_bit_only`, SLR,
+is the negative control) and the level itself has to come out of
+`LogRel.sort_iff`.  It charges depth `0` and nothing more, because the
+*subject* of the observation is a syntactic sort, whose certificate is the
+nullary `HasTypeStratifiedS.sort'` at depth `0`
+(`HasTypeStratifiedS.sort_zero`, SLR).  A leaf therefore supplies no anchor
+here at all, which is exactly the asymmetry with `LRS.PiPathInv`, whose
+subject is an arbitrary type. -/
+
+/-- **The depth-0 producer.**  Bounded adequacy at depth `0` already delivers
+full sort injectivity, in every context and at every level pair — no
+restriction to shallow subjects survives, because the observation's subject is
+a sort. -/
+theorem LRS.SortInv.of_adequacyAtDepth_zero
+    (adequacy : LR.ContextualAdequacyAtDepth 0) : LRS.SortInv :=
+  fun hΓ h =>
+    IsDefEqStrong.sort_inv_of_adequacyAtDepth (adequacy hΓ) (h.strong hΓ)
+      HasTypeStratifiedS.sort_zero
+
+/-- The same producer in `…At` form, matching `JointStratifiedInversionAt`. -/
+theorem LRS.SortInvAt.of_adequacyAtDepth_zero
+    (adequacy : LR.ContextualAdequacyAtDepth 0) : LRS.SortInvAt 0 := by
+  intro Γ u v V B core d hd hΓ hEq hstrat
+  cases Nat.le_zero.1 hd
+  exact IsDefEqStrong.sort_inv_of_adequacyAtDepth (adequacy hΓ) (hEq.strong hΓ)
+    hstrat
+
+/-- **The depth arithmetic.**  Restated in the exact shape the depth bootstrap
+hands to a leaf (compare `JointStratifiedPathInversionAt.of_predecessorAdequacy`
+and `LR.FixedHeadTypeValidStep.of_lowerAdequacy`): at any rung `depth ≥ 1`, the
+*strictly smaller* adequacy family already supplies the whole of
+`LRS.SortInv`.  Consumed at rung `depth`, produced at rung `0`; `0 < depth`, so
+this is strictly below, not same-rung. -/
+theorem LRS.SortInv.of_lowerAdequacy {depth : Nat} (hdepth : 0 < depth)
+    (lower : ∀ d, d < depth → LR.ContextualAdequacyAtDepth d) : LRS.SortInv :=
+  LRS.SortInv.of_adequacyAtDepth_zero (lower 0 hdepth)
+
+/-- The three disjointness facts are available at rung `0` as well, where the
+strictly-lower family is **empty**.  This is the sharpest possible form of
+"strictly below the consumer": below every rung, including the base. -/
+theorem LRS.shapeDisj_at_rung_zero
+    (_lower : ∀ d, d < 0 → LR.ContextualAdequacyAtDepth d) :
+    LRS.SortForallEDisj ∧ LRS.PiNotFunTyped ∧ LRS.PiNotProof :=
+  ⟨LRS.SortForallEDisj.of_soundness, LRS.PiNotFunTyped.of_soundness,
+    LRS.PiNotProof.of_soundness⟩
+
+/-- All four §4.4 facts as one package, from a strictly-lower adequacy family
+at any positive rung.  Three of its four fields need no input at all. -/
+theorem LRS.ShapeDisj.of_lowerAdequacy {depth : Nat} (hdepth : 0 < depth)
+    (lower : ∀ d, d < depth → LR.ContextualAdequacyAtDepth d) :
+    LRS.ShapeDisj where
+  sortInv := LRS.SortInv.of_lowerAdequacy hdepth lower
+  sortForallEDisj := LRS.SortForallEDisj.of_soundness
+  piNotFunTyped := LRS.PiNotFunTyped.of_soundness
+  piNotProof := LRS.PiNotProof.of_soundness
+
+/-- Depth-bounded adequacy exposes the Pi domains and codomains selected by
+one strong equality.  The result deliberately remains path-valued: collapsing
+those heterogeneous paths is the recursive part of the depth bootstrap. -/
+theorem IsDefEqStrong.forallE_invPath_of_adequacyAtDepth
+    {Γ : List SExpr} {A B A' B' V : SExpr} {core : Bool}
+    {s : SLevel} {depth : Nat}
+    (adequacy : LR.AdequacyAtDepth Γ depth)
+    (d : IsDefEqStrong Γ (.forallE A B) (.forallE A' B') (.sort s))
+    (hstrat : HasTypeStratifiedS Γ (.forallE A B) V core depth) :
+    ∃ u v, TypeDefEqPath Γ A A' u ∧
+      TypeDefEqPath (A :: Γ) B B' v := by
+  let p : WShape 1 := .forallE (.bot : WShape 0) WShapeFun.bot
+  have hPi : LE_Interp .nil p.T (.forallE A B) := by
+    refine .forallE' .bot .bot (.bot <| .bot' .sort) fun _ h => ?_
+    cases h.bot_r
+    exact WShapeFun.bot_app.symm ▸ .bot
+  have hmem : p.HasType (.sort (s ≠ .zero)) := by
+    refine WShape.HasType.forallE_l.2 ⟨_, ?_, rfl⟩
+    refine WShape.HasTypePi.iff.2 ⟨.bot (.bot' .sort), fun x hx => ?_⟩
+    cases WShape.HasType.bot_r hx
+    exact WShapeFun.bot_app.symm ▸ .bot .sort
+  have hSort : LE_Interp .nil
+      (WShape.T (n := 1) (.sort (s ≠ .zero))) (.sort s) :=
+    .sort TShape.sort_eqv.1
+  have hrel := (adequacy d hstrat hPi hSort hmem).2 .id
+  have hrel' := subst_id ▸ subst_id ▸ subst_id ▸ hrel
+  change LRS.TyDefEq (LR0 (Γ := Γ)) (.forallE A B) (.forallE A' B') p at hrel'
+  obtain ⟨A₀, B₀, A₁, B₁, u, v,
+      hred₀, hred₁, hdom, hcod, _⟩ := hrel'
+  cases WHNF.forallE.whRedS hred₀
+  cases WHNF.forallE.whRedS hred₁
+  exact ⟨u, v, hdom, hcod⟩
+
+/-- Assemble the path-valued inversion rung from all bounded adequacy facts
+up to `depth`.  This theorem is the semantic half of the depth bootstrap;
+it performs no path collapse and therefore consumes no uniqueness theorem. -/
+theorem JointStratifiedPathInversionAt.of_adequacyAtDepth
+    (depth : Nat)
+    (adequacy : ∀ d, d ≤ depth → LR.ContextualAdequacyAtDepth d) :
+    JointStratifiedPathInversionAt depth where
+  sortInv hd hΓ h hstrat :=
+    h.sort_inv_of_adequacyAtDepth (adequacy _ hd hΓ) hstrat
+  forallEInv := by
+    intro Γ A B A' B' V V' s n n' hn hn' hΓ h hL hR
+    obtain ⟨uL, vL, hAL, hBL⟩ := hL.forallE_inv
+    obtain ⟨uR, vR, hAR, hBR⟩ := hR.forallE_inv
+    obtain ⟨up, vp, hAA, hBB⟩ :=
+      h.forallE_invPath_of_adequacyAtDepth (adequacy _ hn hΓ) hL
+    exact ⟨⟨up, uL, uR, hAA, hAL, hAR⟩,
+      vp, vL, vR, hBB, hBL, hBR⟩
+
+/-- Restate the bounded inversion rung against a strict predecessor
+family: the contextual adequacy rungs strictly below `depth + 1` are
+exactly the bounded family up to `depth`.  This is the form a successor
+joint leaf receives from the depth bootstrap, so the leaf can assemble
+its own predecessor inversion package without a same-depth adequacy
+consumption. -/
+theorem JointStratifiedPathInversionAt.of_predecessorAdequacy
+    (depth : Nat)
+    (adequacy : ∀ d, d < depth + 1 → LR.ContextualAdequacyAtDepth d) :
+    JointStratifiedPathInversionAt depth :=
+  .of_adequacyAtDepth depth fun d hd => adequacy d (Nat.lt_succ_of_le hd)
+
+/-- Construct the direct stratified inversion package from positive adequacy
+without assuming raw type uniqueness.  The path-valued bootstrap above first
+derives uniqueness and collapses its own paths; this theorem merely aligns
+the endpoint stratification indices with those collapsed equalities. -/
+theorem JointStratifiedInversion.of_adequacy
+    (adequacy : LR.ContextualAdequacyAt 1) :
+    JointStratifiedInversion where
+  sortInv := by
+    intro Γ u v V hΓ h
+    let m : WShape 1 := .sort (decide (u ≠ .zero))
+    have hstart : LE_Interp .nil m.T (.sort u) :=
+      .sort TShape.sort_eqv.1
+    obtain ⟨_, w, hu, hv⟩ :=
+      h.sort_observe_of_adequacy (adequacy hΓ) hstart
+    cases WHNF.sort.whRedS hu
+    cases WHNF.sort.whRedS hv
+    rfl
+  forallEInv := by
+    intro Γ A B A' B' V V' s n n' hΓ h hL hR
+    let inv := JointStratifiedPathInversion.of_adequacy adequacy
+    obtain ⟨⟨up, uL, uR, hAAp, hAL, hAR⟩,
+        vp, vL, vR, hBBp, hBL, hBR⟩ :=
+      inv.forallEInv hΓ (.single h.defeq) hL hR
+    have hAA := hAAp.collapse_of_stratified_inversion inv hΓ
+    obtain ⟨_, huLp⟩ :=
+      IsDefEq.uniqPath_of_stratified_inversion
+        inv hΓ hAL.hasType hAA.hasType.1
+    have huL : uL = up := inv.sortPathInv hΓ huLp
+    cases huL
+    obtain ⟨_, huRp⟩ :=
+      IsDefEq.uniqPath_of_stratified_inversion
+        inv hΓ hAR.hasType hAA.hasType.2
+    have huR : uR = up := inv.sortPathInv hΓ huRp
+    cases huR
+    have hΓA : Ctx.WF (A :: Γ) := ⟨hΓ, ⟨up, hAA.hasType.1⟩⟩
+    have hBB := hBBp.collapse_of_stratified_inversion inv hΓA
+    obtain ⟨_, hvLp⟩ :=
+      IsDefEq.uniqPath_of_stratified_inversion
+        inv hΓA hBL.hasType hBB.hasType.1
+    have hvL : vL = vp := inv.sortPathInv hΓA hvLp
+    cases hvL
+    have hΓA' : Ctx.WF (A' :: Γ) := ⟨hΓ, ⟨up, hAA.hasType.2⟩⟩
+    have hBB' : IsDefEq (A' :: Γ) B' B' (.sort vp) :=
+      hAA.defeqDF_l hBB.hasType.2
+    obtain ⟨_, hvRp⟩ :=
+      IsDefEq.uniqPath_of_stratified_inversion
+        inv hΓA' hBR.hasType hBB'
+    have hvR : vR = vp := inv.sortPathInv hΓA' hvRp
+    cases hvR
+    exact ⟨⟨up, hAA, hAL⟩, vp, hBB, hBL, hBR⟩
+
+/-- Raw weak type uniqueness from only stratified sort and Pi inversion.
+
+The proof is well founded on the maximum stratification depth.  Its
+application and lambda cases recurse under a binder; this is why both the
+inversion package and the eventual adequacy stage must be contextual. -/
+theorem IsDefEq.uniq_of_stratified_inversion
+    (inv : JointStratifiedInversion) (hΓ : Ctx.WF Γ)
+    (h1 : IsDefEq Γ e₁ e₂ A) (h2 : IsDefEq Γ e₂ e₃ B) :
+    ∃ u, IsDefEq Γ A B (.sort u) := by
+  suffices ∀ {e A B b n₁ n₂ n}, n₁ ≤ n → n₂ ≤ n →
+      HasTypeStratifiedS Γ e A b n₁ →
+      HasTypeStratifiedS Γ e B b n₂ →
+      ∃ u, IsDefEq Γ A B (.sort u) ∧
+        HasTypeStratifiedS Γ A (.sort u) true (n - 1) ∧
+        HasTypeStratifiedS Γ B (.sort u) true (n - 1) by
+    obtain ⟨n₁, _, h1A⟩ := (h1.strong hΓ).stratify
+    obtain ⟨n₂, h2B, _⟩ := (h2.strong hΓ).stratify
+    obtain ⟨u, h, _⟩ := this (Nat.le_max_left ..) (Nat.le_max_right ..) h1A h2B
+    exact ⟨u, h⟩
+  clear h1 h2
+  intro e A B b n₁ n₂ n le₁ le₂ H1
+  induction n using WellFounded.induction Nat.lt_wfRel.2
+    generalizing n₁ n₂ Γ e A B b with
+  | _ n IH =>
+  induction H1 generalizing B n₂ n with
+  | bvar a1 a2 =>
+    intro (.bvar b1 b2)
+    cases a1.uniq b1
+    exact ⟨_, b2.hasType,
+      b2.mono (Nat.sub_le_sub_right le₂ 1),
+      b2.mono (Nat.sub_le_sub_right le₂ 1)⟩
+  | sort' =>
+    intro (.sort')
+    exact ⟨_, .sort, .base .sort', .base .sort'⟩
+  | const a1 a2 a3 =>
+    intro (.const b1 b2 b3)
+    cases a1.symm.trans b1
+    replace le₁ := Nat.sub_le_sub_right le₁ 1
+    exact ⟨_, a3.hasType, a3.mono le₁, a3.mono le₁⟩
+  | app a1 a2 a3 a4 a5 ih1 ih2 ih3 ih4 ih5 =>
+    intro (.app b1 b2 b3 b4 b5)
+    have ⟨_, c1, c3, c4⟩ :=
+      ih3 n IH hΓ (Nat.le_of_succ_le le₁) (Nat.le_of_succ_le le₂) b3
+    have ⟨⟨_, d1, d2⟩, _, d3, d4, d5⟩ :=
+      inv.forallEInv hΓ (c1.strong hΓ) c3 c4
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have hΓA : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have d4n := d4.mono (n := n) (by omega)
+    have ⟨_, e1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₁ (Nat.le_refl _) a2 d4n
+    have ev1 := inv.sortInv hΓA (e1.strong hΓA)
+    have hΓB : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, b1.hasType⟩⟩
+    have d5n := d5.mono (n := n) (by omega)
+    have ⟨_, e2, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓB le₂ (Nat.le_refl _) b2 d5n
+    have ev2 := inv.sortInv hΓB (e2.strong hΓB)
+    cases ev1
+    cases ev2
+    have hinst := d3.subst
+      (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar a4.hasType)
+    simpa using ⟨_, hinst, a5.mono le₁, b5.mono le₂⟩
+  | lam a1 a2 a3 a4 ih1 ih2 ih3 ih4 =>
+    intro (.lam b1 b2 b3 b4)
+    have hΓA : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have ⟨_, c1, c3, c4⟩ := ih3 n IH hΓA
+      (Nat.le_of_succ_le le₁) (Nat.le_of_succ_le le₂) b3
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have ⟨_, d1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ le₁ le₂ a1 b1
+    have eu := inv.sortInv hΓ (d1.strong hΓ)
+    cases eu
+    have ⟨_, d2, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₁ (Nat.le_refl _) a2 c3
+    have ev1 := inv.sortInv hΓA (d2.strong hΓA)
+    cases ev1
+    have ⟨_, d3, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓA le₂ (Nat.le_refl _) b2 c4
+    have ev2 := inv.sortInv hΓA (d3.strong hΓA)
+    cases ev2
+    exact ⟨_, .forallEDF a1.hasType c1, a4.mono le₁, b4.mono le₂⟩
+  | forallE a1 a2 ih1 ih2 =>
+    intro (.forallE b1 b2)
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    replace le₂ := Nat.le_of_succ_le_succ le₂
+    have ⟨_, hA, _, _⟩ := IH _ (Nat.lt_succ_self _) hΓ le₁ le₂ a1 b1
+    have eu := inv.sortInv hΓ (hA.strong hΓ)
+    cases eu
+    have hΓ' : Ctx.WF (_ :: _) := ⟨hΓ, ⟨_, a1.hasType⟩⟩
+    have ⟨_, hB, _, _⟩ := IH _ (Nat.lt_succ_self _) hΓ' le₁ le₂ a2 b2
+    have ev := inv.sortInv hΓ' (hB.strong hΓ')
+    cases ev
+    exact ⟨_, .sort, .base .sort', .base .sort'⟩
+  | @base Γ e A n₁ a1 ih =>
+    intro H2
+    replace ih {n'} le :=
+      @ih n' (fun y hlt => IH y (Nat.lt_of_lt_of_le hlt le)) hΓ
+    generalize eq : true = b at H2
+    induction H2 with cases eq
+    | base b1 _ => exact ih (Nat.le_refl _) le₁ le₂ b1
+    | defeq bEq bA bB be ihA' ihB' ihe' =>
+      have ⟨_, c1, c3, c4⟩ :=
+        ihe' a1 hΓ (Nat.le_of_succ_le le₂) ih rfl
+      let n + 1 := n
+      replace le₂ := Nat.le_of_succ_le_succ le₂
+      have ⟨_, d1, _, _⟩ :=
+        IH _ (Nat.lt_succ_self _) hΓ le₂ (Nat.le_refl _) bA c4
+      have eu := inv.sortInv hΓ (d1.strong hΓ)
+      cases eu
+      exact ⟨_, c1.trans bEq.defeq, c3, bB.mono le₂⟩
+  | defeq hEq hA hB he ihA ihB ihe =>
+    intro H2
+    have ⟨_, c1, c3, c4⟩ :=
+      ihe n IH hΓ (Nat.le_of_succ_le le₁) le₂ H2
+    let n + 1 := n
+    replace le₁ := Nat.le_of_succ_le_succ le₁
+    have ⟨_, d1, _, _⟩ :=
+      IH _ (Nat.lt_succ_self _) hΓ le₁ (Nat.le_refl _) hA c3
+    have eu := inv.sortInv hΓ (d1.strong hΓ)
+    cases eu
+    exact ⟨_, hEq.defeq.symm.trans c1, hB.mono le₁, c4⟩
+
+/-- Strip outer conversions from a stratified typing and align the resulting
+syntax-directed core type with the original type. -/
+theorem HasTypeStratifiedS.core_aligned_of_typeUniq
+    (uniq : LogRel.RawTypeUniq Γ)
+    (H : HasTypeStratifiedS Γ e A true n) :
+    ∃ A' u, HasTypeStratifiedS Γ e A' false n ∧
+      IsDefEq Γ A' A (.sort u) := by
+  obtain ⟨A', hcore⟩ := H.to_core
+  obtain ⟨u, hty⟩ := uniq hcore.hasType H.hasType
+  exact ⟨A', u, hcore, hty⟩
+
+/-- Every weak self-typing has a syntax-directed stratified core, with its
+type aligned by the joint inversion theorem. -/
+theorem IsDefEq.core_aligned_of_stratified_inversion
+    (inv : JointStratifiedInversion) (hΓ : Ctx.WF Γ)
+    (H : IsDefEq Γ e e A) :
+    ∃ n A' u, HasTypeStratifiedS Γ e A' false n ∧
+      IsDefEq Γ A' A (.sort u) := by
+  obtain ⟨n, hs, _⟩ := (H.strong hΓ).stratify
+  obtain ⟨A', u, hcore, hty⟩ :=
+    hs.core_aligned_of_typeUniq (fun h1 h2 =>
+      IsDefEq.uniq_of_stratified_inversion inv hΓ h1 h2)
+  exact ⟨n, A', u, hcore, hty⟩
+
+/-- One weak-head step preserves a supplied type once the joint stratified
+inversion package is available.  Application reduction recurses at the
+syntax-directed function/argument typing; beta uses Pi inversion to align
+the lambda's native binder with the application's domain; a registered
+step uses the type carried by its `Pattern.Action`. -/
+theorem WHRed.defeq_of_stratified_inversion
+    (inv : JointStratifiedInversion) (hΓ : Ctx.WF Γ)
+    (H : WHRed Γ e1 e2) (he : IsDefEq Γ e1 e1 A) :
+    IsDefEq Γ e1 e2 A := by
+  let uniq : LogRel.RawTypeUniq Γ := fun h1 h2 =>
+    IsDefEq.uniq_of_stratified_inversion inv hΓ h1 h2
+  induction H generalizing A with
+  | app hred ih =>
+    obtain ⟨_, _, _, hcore, hty⟩ :=
+      he.core_aligned_of_stratified_inversion inv hΓ
+    cases hcore with
+    | app hD hC hf ha hR =>
+      exact hty.defeqDF (.appDF (ih hf.hasType) ha.hasType)
+  | major hmajor hred ih =>
+    obtain ⟨_, _, _, hcore, hty⟩ :=
+      he.core_aligned_of_stratified_inversion inv hΓ
+    cases hcore with
+    | app hD hC hf ha hR =>
+      exact hty.defeqDF (.appDF hf.hasType (ih ha.hasType))
+  | beta =>
+    obtain ⟨_, _, _, hcore, hty⟩ :=
+      he.core_aligned_of_stratified_inversion inv hΓ
+    cases hcore with
+    | app hD hC hlam ha hR =>
+      obtain ⟨_, _, _, hlamCore, hlamTy⟩ :=
+        hlam.hasType.core_aligned_of_stratified_inversion inv hΓ
+      cases hlamCore with
+      | lam hDom hCod hBody hPi =>
+        have hPiRight := HasTypeStratifiedS.base
+          (HasTypeStratifiedS.forallE hD hC)
+        have ⟨⟨_, hDomEq, _⟩, _, hCodEq, _, _⟩ :=
+          inv.forallEInv hΓ (hlamTy.strong hΓ) hPi hPiRight
+        have haDom := hDomEq.symm.defeqDF ha.hasType
+        have hβ := IsDefEq.beta hBody.hasType haDom
+        have hCodInst := hCodEq.subst
+          (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar haDom)
+        exact hty.defeqDF (hCodInst.defeqDF hβ)
+  | extra action =>
+    obtain ⟨_, _, _, hcore, hty⟩ :=
+      he.core_aligned_of_stratified_inversion inv hΓ
+    obtain ⟨_, hActionTy⟩ := uniq hcore.hasType action.sound.hasType.1
+    exact hty.defeqDF (hActionTy.symm.defeqDF action.sound)
+
+/-- Multi-step weak-head subject reduction from the same joint inversion
+package.  Each next step is typed by the previous step's right endpoint. -/
+theorem WHRedS.defeq_of_stratified_inversion
+    (inv : JointStratifiedInversion) (hΓ : Ctx.WF Γ)
+    (H : WHRedS Γ e1 e2) (he : IsDefEq Γ e1 e1 A) :
+    IsDefEq Γ e1 e2 A := by
+  induction H with
+  | rfl => exact he
+  | tail hred hstep ih =>
+    exact ih.trans
+      (hstep.defeq_of_stratified_inversion inv hΓ ih.hasType.2)
+
+/-- One completed stage of the contextual joint development.  The indices
+are deliberately offset: adequacy at the first positive shape level supplies
+the sort/Pi observations used to establish limited uniqueness at level zero.
+The latter is then consumed while constructing adequacy one level higher. -/
+structure LR.JointStage (n : Nat) : Prop where
+  adequacyNext : LR.ContextualAdequacyAt (n + 1)
+  uniq : LogRel.ContextualLimitedUniq n
+
+/-- The acyclic builder for the joint adequacy/uniqueness tower.
+
+The former interface claimed that `LimitedUniq (LR Γ₀ n)` followed from
+`AdequacyAt Γ₀ n` alone.  That is too strong: at bottom shapes the logical
+relation forgets the weak typing evidence, and an arbitrary target context
+need not even be well formed.  The actual shape induction has a positive
+bootstrap.  Level-zero adequacy is built first; a specialized base argument
+builds level-one adequacy without predecessor uniqueness.  The path-level
+positive bootstrap derives stratified inversion and raw weak type uniqueness
+from that package, hence level-zero alignment, with no additional callback.
+Each later stage consumes alignment at `n` to build adequacy at `n + 2`, then
+proves only the exact, term-indexed lambda-retyping case at `n + 1`;
+`LRS.limitedUniq_of_typeUniq` discharges every other shape.  Successor
+adequacy also receives adequacy at `n + 1`: transport frames can finish a
+native result at a lifted observation and need the already-built lower
+theorem to reconstruct the endpoint self-relations before semantic
+retyping.  Predecessor uniqueness alone does not provide those witnesses. -/
+structure LR.JointBuilder : Prop where
+  zero : LR.ContextualAdequacyAt 0
+  first : LR.ContextualAdequacyAt 0 → LR.ContextualAdequacyAt 1
+  succ : ∀ n, LR.ContextualAdequacyAt (n + 1) →
+    LogRel.ContextualLimitedUniq n →
+    LR.ContextualAdequacyAt (n + 2)
+  uniqSucc : ∀ n,
+    LogRel.ContextualLimitedUniq n →
+    LR.ContextualAdequacyAt (n + 2) →
+    LogRel.ContextualLamRetype n
+
+/-- The context-wide raw uniqueness fact is obtained once from the positive
+bootstrap and reused at every successor stratum. -/
+theorem LR.JointBuilder.rawTypeUniq (B : LR.JointBuilder) :
+    LogRel.ContextualRawTypeUniq :=
+  LogRel.contextualRawTypeUniq_of_adequacy (B.first B.zero)
+
+/-- The base inversion package selected by the completed positive
+bootstrap. -/
+theorem LR.JointBuilder.stratifiedInversion (B : LR.JointBuilder) :
+    JointStratifiedInversion :=
+  JointStratifiedInversion.of_adequacy (B.first B.zero)
+
+/-- The exact root subject-reduction callback consumed by normalized
+constructor chains. -/
+theorem WHRedS.defeq_of_jointBuilder
+    (B : LR.JointBuilder) (hΓ : Ctx.WF Γ)
+    (H : WHRedS Γ e1 e2) (he : IsDefEq Γ e1 e1 A) :
+    IsDefEq Γ e1 e2 A :=
+  H.defeq_of_stratified_inversion B.stratifiedInversion hΓ he
+
+/-- Consume a normalized constructor observation with both root reductions
+discharged by a supplied stratified inversion package.  Native links are
+retyped using the raw uniqueness theorem derived from that same package.
+
+This is the depth-bootstrap consumer boundary: a caller may use the
+strictly earlier inversion rung directly, without first manufacturing the
+completed level-polymorphic `JointBuilder`. -/
+theorem LRS.CtorDefEq.foldRaw_of_stratifiedInversion
+    (inv : JointStratifiedInversion) (hΓ : Ctx.WF Γ)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (hM : IsDefEq Γ M M D) (hN : IsDefEq Γ N N D) : Q M N := by
+  let uniq : LogRel.RawTypeUniq Γ := fun h₁ h₂ =>
+    IsDefEq.uniq_of_stratified_inversion inv hΓ h₁ h₂
+  apply H.foldRaw uniq alg
+  · intro X V
+    cases V with
+    | intro hcl hred =>
+      exact hred.defeq_of_stratified_inversion inv hΓ hM
+  · intro Y V
+    cases V with
+    | intro hcl hred =>
+      exact hred.defeq_of_stratified_inversion inv hΓ hN
+
+/-- Compatibility wrapper for callers that already carry the completed
+joint builder. -/
+theorem LRS.CtorDefEq.foldRaw_of_jointBuilder
+    (B : LR.JointBuilder) (hΓ : Ctx.WF Γ)
+    (alg : LRS.CtorChain.RawAlgebra Γ IH m D Q)
+    (H : LRS.CtorDefEq Γ IH M N m)
+    (hM : IsDefEq Γ M M D) (hN : IsDefEq Γ N N D) : Q M N :=
+  H.foldRaw_of_stratifiedInversion B.stratifiedInversion hΓ alg hM hN
+
+/-- The exact residual of a normalized constructor-chain fold, named apart
+from any inversion package.
+
+`LRS.CtorPath.foldRaw` spends raw type uniqueness once per interior chain
+vertex — the middle terms introduced by `LRS.CtorDefEq.trans`, which
+retains no typing for them — and `LRS.CtorChain.foldRaw`'s two root
+callbacks are exactly weak-head subject reduction at the two endpoints.
+Nothing else is consumed by the fold, so the two facts are recorded here as
+separate fields rather than bundled as `JointStratifiedInversion`: a
+producer may reach either half by other means.
+
+This is the whole major-side residual of the coherent iota leaf.  The
+per-link consumers (`LRS.iotaDefEq_of_ctorExactAt_coherent` and the
+synchronized rectangle `LRS.iotaDefEqRect_of_ctorExactAt`) consume no
+inversion, uniqueness or subject-reduction fact at all.
+
+Neither field is reachable from a strict predecessor adequacy rung: an
+interior vertex is an arbitrary term whose stratified depth is bounded by
+no certificate available at the leaf.  See the 2026-08-15 rung audit in
+`plans/l4l-16c-buildp-premortem.md`. -/
+structure LR.MajorChainFoldStep (Γ₀ : List SExpr) : Prop where
+  /-- Retyping of the interior chain vertices at the externally chosen
+  domain. -/
+  uniq : LogRel.RawTypeUniq Γ₀
+  /-- The two root views' weak-head reductions preserve the root domain. -/
+  subjectRed : ∀ {e₁ e₂ A : SExpr}, WHRedS Γ₀ e₁ e₂ →
+    IsDefEq Γ₀ e₁ e₁ A → IsDefEq Γ₀ e₁ e₂ A
+
+/-- The completed inversion package supplies both halves.  This certifies
+that the two named fields are precisely the facts the existing
+`foldRaw_of_stratifiedInversion` consumer spends, with nothing else hidden
+in the package. -/
+theorem LR.MajorChainFoldStep.of_stratifiedInversion
+    (inv : JointStratifiedInversion) (hΓ₀ : Ctx.WF Γ₀) :
+    LR.MajorChainFoldStep Γ₀ where
+  uniq h₁ h₂ := IsDefEq.uniq_of_stratified_inversion inv hΓ₀ h₁ h₂
+  subjectRed hred he := hred.defeq_of_stratified_inversion inv hΓ₀ he
+
+/-- Consume the free constructor-observation closure from the named
+chain-fold residual alone.  No well-formedness hypothesis and no inversion
+package appear: both are already spent inside the two fields. -/
+theorem LRS.CtorDefEq.foldRaw_of_majorChainFoldStep
+    (step : LR.MajorChainFoldStep Γ₀)
+    (alg : LRS.CtorChain.RawAlgebra Γ₀ IH m D Q)
+    (H : LRS.CtorDefEq Γ₀ IH M N m)
+    (hM : IsDefEq Γ₀ M M D) (hN : IsDefEq Γ₀ N N D) : Q M N := by
+  apply H.foldRaw step.uniq alg
+  · intro X V
+    cases V with
+    | intro _ hred => exact step.subjectRed hred hM
+  · intro Y V
+    cases V with
+    | intro _ hred => exact step.subjectRed hred hN
+
+/-- The chain-fold residual after the 2026-08-15 structural repair.
+
+`LR.MajorChainFoldStep` above is the residual as it stood: raw type uniqueness
+for *arbitrary* terms at *arbitrary* types, plus *unrestricted* weak-head
+subject reduction.  Both fields are weakened here, independently:
+
+* `ctorRetype` replaces `LogRel.RawTypeUniq Γ₀` by the per-leaf transport of
+  `LRS.CtorAnchorDisciplineAt`.  Its subject always carries a native
+  `LRS.CtorExact` certificate — head typing, telescope and field payload all
+  retained — and it is scoped to a frame of the root observation.  This is the
+  field that removed the chain's interior vertices from the obligation
+  altogether: `LRS.CtorPath.foldRaw_of_anchorDiscipline` identifies no types.
+* `rootRed` replaces unrestricted subject reduction by subject reduction *to a
+  classified constructor spine*.  That is exactly the two root callbacks of
+  `LRS.CtorChain.foldRaw`, i.e. the two endpoint majors — the terms a redex's
+  own stratified certificate does bound, via `HasTypeStratifiedS.app`.
+
+The reduction is faithful in the checkable sense: `of_majorChainFoldStep`
+below derives this Prop from the old one, so nothing has been strengthened,
+and `LRS.CtorDefEq.foldRaw_of_majorChainAnchorStep` reaches the same
+conclusion as `foldRaw_of_majorChainFoldStep` from the weaker inputs. -/
+structure LR.MajorChainAnchorStep (Γ₀ : List SExpr) : Prop where
+  /-- Each framed native leaf retypes itself at any domain typing one of its
+  endpoints. -/
+  ctorRetype : ∀ {n k : Nat} {IH : LogRel Γ₀ n} {J : LogRel Γ₀ k}
+      {m : WShape (n + 1)} {p : WShape (k + 1)} {X Y : SExpr},
+      LRS.CtorFrame Γ₀ IH m J p → LRS.CtorExact Γ₀ J X Y p →
+      LRS.CtorRetype Γ₀ X Y
+  /-- Weak-head reduction of a root to its classified constructor spine
+  preserves the root's type. -/
+  rootRed : ∀ {M X A : SExpr}, LRS.CtorView Γ₀ M X →
+      IsDefEq Γ₀ M M A → IsDefEq Γ₀ M X A
+
+/-- The environment-level constructor result-type discipline plus root subject
+reduction supply the step.  This is the intended producer: the first component
+has no depth index at all, having left the adequacy fixpoint entirely. -/
+theorem LR.MajorChainAnchorStep.of_ctorSpineTypeUniqPath
+    (disc : LRS.CtorSpineTypeUniqPath Γ₀)
+    (red : ∀ {M X A : SExpr}, LRS.CtorView Γ₀ M X →
+      IsDefEq Γ₀ M M A → IsDefEq Γ₀ M X A) :
+    LR.MajorChainAnchorStep Γ₀ where
+  ctorRetype _ leaf := leaf.retype_of_ctorSpineTypeUniqPath disc
+  rootRed := red
+
+/-- The previous residual implies the repaired one, so the repair is a
+weakening and not a restatement. -/
+theorem LR.MajorChainAnchorStep.of_majorChainFoldStep
+    (step : LR.MajorChainFoldStep Γ₀) : LR.MajorChainAnchorStep Γ₀ :=
+  LR.MajorChainAnchorStep.of_ctorSpineTypeUniqPath
+    (LRS.CtorSpineTypeUniqPath.of_rawTypeUniq step.uniq)
+    (fun V he => by
+      cases V with
+      | intro _ hred => exact step.subjectRed hred he)
+
+/-- **Both fields of the repaired residual, from one depth-free proposition.**
+
+`LRS.PiPathInv` — Pi injectivity for heterogeneous type paths — discharges
+`ctorRetype` and `rootRed` together.  What that replaces is worth stating
+exactly, since it is the whole content of the 2026-08-15 repair:
+
+* `ctorRetype` used to be `LogRel.RawTypeUniq Γ₀` at arbitrary terms.  It is
+  now the environment-level fact that a *registered-constant* spine has one
+  result type (`LRS.constSpineTypeUniqPath`), which reduces to Pi injectivity
+  plus two premise-free steps — `HasTypeStratifiedS.spineWF_of_foldl` and
+  `LRS.constTypeUniqPath`, the latter consuming nothing at all.
+* `rootRed` used to be subject reduction from the full
+  `JointStratifiedInversion` package.  It is now
+  `WHRedS.defeq_of_piPathInv`, whose per-step lemma names no depth, so the
+  multi-step induction re-certifies nothing.  The general form is proved:
+  the restriction to classified spines is not used.
+
+Nothing below charges `TypeDefEqPath.collapse` (raw type uniqueness),
+`sortPathInv`, or any stratification index. -/
+theorem LR.MajorChainAnchorStep.of_piPathInv
+    (piInv : LRS.PiPathInv) (hΓ₀ : Ctx.WF Γ₀) :
+    LR.MajorChainAnchorStep Γ₀ :=
+  LR.MajorChainAnchorStep.of_ctorSpineTypeUniqPath
+    (LRS.CtorSpineTypeUniqPath.of_piPathInv piInv hΓ₀)
+    (fun V he => by
+      cases V with
+      | intro _ hred => exact hred.defeq_of_piPathInv piInv hΓ₀ he)
+
+/-- **The same, back to the ladder rungs** (2026-08-15).  With rung R11 landed
+(`LRS.PiEdgeInv.of_crLadder`, SLR) the sole input of `of_piPathInv` above is
+itself produced by `LRS.PiPathInv.of_crLadder_R11`, so the whole
+constructor-observation anchor rests on three Church–Rosser / standardization
+rungs and **no adequacy rung at all**.
+
+Recorded because it settles the *ADQ-fixpoint* scheduling question for this
+residual the same way `LRS.PiPathInv.of_crLadder_noAdequacy` settles it for the
+chain wall: the anchor step needs nothing from the adequacy fixpoint.
+
+It does **not** make the anchor cheaper than the leaf.  The three ladder rungs
+are downstream of `LRS.PiPathInv` itself — see the circularity note on
+`LRS.crComplete_is_the_last_input` (SLR) — so the honest reading is "the anchor
+costs exactly the leaf, and nothing beyond it". -/
+theorem LR.MajorChainAnchorStep.of_crLadder
+    (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete) (std : LRS.PiStandard)
+    (hΓ₀ : Ctx.WF Γ₀) : LR.MajorChainAnchorStep Γ₀ :=
+  LR.MajorChainAnchorStep.of_piPathInv
+    (LRS.PiPathInv.of_crLadder_R11 srp cr std) hΓ₀
+
+/-- The free constructor-observation closure folds from the repaired residual
+alone.  Same statement as `LRS.CtorDefEq.foldRaw_of_majorChainFoldStep`, with
+the interior of the chain no longer spending any type identification:
+`ctorRetype` is used once per native leaf and `rootRed` only at the two root
+views. -/
+theorem LRS.CtorDefEq.foldRaw_of_majorChainAnchorStep
+    (step : LR.MajorChainAnchorStep Γ₀)
+    (alg : LRS.CtorChain.RawAlgebra Γ₀ IH m D Q)
+    (H : LRS.CtorDefEq Γ₀ IH M N m)
+    (hM : IsDefEq Γ₀ M M D) (hN : IsDefEq Γ₀ N N D) : Q M N := by
+  have disc : LRS.CtorAnchorDisciplineAt Γ₀ IH m :=
+    fun frame leaf => step.ctorRetype frame leaf
+  refine H.foldRaw_of_anchorDiscipline disc alg ?_ ?_
+  · intro X V
+    exact step.rootRed V hM
+  · intro Y V
+    exact step.rootRed V hN
+
+/-- Primitive recursion realizes the offset joint tower; no stage requests
+same-level uniqueness before constructing the positive-level adequacy that
+justifies it. -/
+theorem LR.JointBuilder.build (B : LR.JointBuilder) :
+    ∀ n, LR.JointStage n
+  | 0 =>
+    let adequacyNext : LR.ContextualAdequacyAt 1 := B.first B.zero
+    { adequacyNext := adequacyNext
+      uniq := fun hΓ => LR0.limitedUniq_of_typeUniq
+        (B.rawTypeUniq hΓ) }
+  | n + 1 =>
+    let prev := B.build n
+    let adequacyNext : LR.ContextualAdequacyAt (n + 2) :=
+      B.succ n prev.adequacyNext prev.uniq
+    { adequacyNext := adequacyNext
+      uniq := fun hΓ => LRS.limitedUniq_of_typeUniq
+        (B.rawTypeUniq hΓ) (B.uniqSucc n prev.uniq adequacyNext hΓ) }
+
+/-- Recover adequacy at every shape level from the offset tower. -/
+theorem LR.JointBuilder.adequacy (B : LR.JointBuilder) :
+    ∀ n, LR.ContextualAdequacyAt n
+  | 0 => B.zero
+  | n + 1 => (B.build n).adequacyNext
+
+/-- Recover limited uniqueness at every predecessor level. -/
+theorem LR.JointBuilder.limitedUniq (B : LR.JointBuilder) (n : Nat) :
+    LogRel.ContextualLimitedUniq n :=
+  (B.build n).uniq
+
+/-- Compatibility name for the corrected builder.  Contextuality is now
+inside every stage rather than wrapped around already-built fixed-context
+towers. -/
+abbrev LR.ContextualJointBuilder := LR.JointBuilder
+
+/-- The contextual tower exports the raw uniqueness package consumed by
+path collapse and binder inversion. -/
+theorem LR.ContextualJointBuilder.rawTypeUniq
+    (B : LR.ContextualJointBuilder) : LogRel.ContextualRawTypeUniq := by
+  exact LR.JointBuilder.rawTypeUniq B
+
+/-- Turn a raw equality between types into a logical type equality once both
+endpoints are already valid at the same observation.
+
+This is the conversion handoff supplied by the merged adequacy/uniqueness
+tower.  Sort observations use typed weak-head subject reduction and sort
+inversion.  At a Pi observation, direct stratified Pi inversion aligns the
+two exposed domains and codomains; the predecessor relation then handles the
+domain and every instantiated codomain recursively.  No general
+Church--Rosser assumption or new evaluator premise is used. -/
+theorem LR.TyDefEq.of_defeq_of_stratifiedInversion
+    (inv : JointStratifiedInversion) :
+    ∀ {n : Nat} {Γ : List SExpr} {A B : SExpr} {u : SLevel}
+      {a : WShape n},
+      Ctx.WF Γ →
+      IsDefEq Γ A B (.sort u) →
+      (LR Γ).TyDefEq A A a →
+      (LR Γ).TyDefEq B B a →
+      (LR Γ).TyDefEq A B a := by
+  intro n
+  induction n with
+  | zero =>
+    intro Γ A B u a hΓ hAB hAA hBB
+    rw [LR_zero] at hAA hBB ⊢
+    cases a using WShape.casesOn with
+    | bot => trivial
+    | sort r =>
+      rcases hAA with ⟨uA, hA, _⟩
+      rcases hBB with ⟨uB, hB, _⟩
+      have hAred := hA.defeq_of_stratified_inversion inv hΓ hAB.hasType.1
+      have hBred := hB.defeq_of_stratified_inversion inv hΓ hAB.hasType.2
+      have hSort : IsDefEq Γ (.sort uA) (.sort uB) (.sort u) :=
+        hAred.symm.trans (hAB.trans hBred)
+      have huv := inv.sortInv hΓ (hSort.strong hΓ)
+      cases huv
+      exact ⟨uA, hA, hB⟩
+  | succ n ih =>
+    intro Γ A B u a hΓ hAB hAA hBB
+    rw [LR_succ] at hAA hBB ⊢
+    cases a using WShape.casesOn' with
+    | bot => trivial
+    | lam => trivial
+    | ctor => trivial
+    | indTy => exact ⟨hAA.1, hBB.2⟩
+    | sort r =>
+      rcases hAA with ⟨uA, hA, _⟩
+      rcases hBB with ⟨uB, hB, _⟩
+      have hAred := hA.defeq_of_stratified_inversion inv hΓ hAB.hasType.1
+      have hBred := hB.defeq_of_stratified_inversion inv hΓ hAB.hasType.2
+      have hSort : IsDefEq Γ (.sort uA) (.sort uB) (.sort u) :=
+        hAred.symm.trans (hAB.trans hBred)
+      have huv := inv.sortInv hΓ (hSort.strong hΓ)
+      cases huv
+      exact ⟨uA, hA, hB⟩
+    | forallE b f =>
+      rcases hAA with
+        ⟨A₁, F₁, A₁', F₁', uA, vA, hA₁, hA₂,
+          hDomA, hCodA, hValDomA, hPiA⟩
+      have hAeq : SExpr.forallE A₁ F₁ = SExpr.forallE A₁' F₁' :=
+        hA₁.determ .forallE hA₂ .forallE
+      cases hAeq
+      rcases hBB with
+        ⟨B₁, G₁, B₁', G₁', uB, vB, hB₁, hB₂,
+          hDomB, hCodB, hValDomB, hPiB⟩
+      have hBeq : SExpr.forallE B₁ G₁ = SExpr.forallE B₁' G₁' :=
+        hB₁.determ .forallE hB₂ .forallE
+      cases hBeq
+      have hAred := hA₁.defeq_of_stratified_inversion inv hΓ hAB.hasType.1
+      have hBred := hB₁.defeq_of_stratified_inversion inv hΓ hAB.hasType.2
+      have hPiEq : IsDefEq Γ (.forallE A₁ F₁) (.forallE B₁ G₁)
+          (.sort u) := hAred.symm.trans (hAB.trans hBred)
+      have hPiStrong := hPiEq.strong hΓ
+      obtain ⟨depth, hPiLeft, hPiRight⟩ := hPiStrong.stratify
+      obtain ⟨⟨uDom, hDom, _⟩, vCod, hCod, _, _⟩ :=
+        inv.forallEInv hΓ hPiStrong hPiLeft hPiRight
+      have hValDom : (LR Γ).TyDefEq A₁ B₁ b :=
+        ih hΓ hDom hValDomA hValDomB
+      have hPi : LRS.PiDefEq (LR Γ) A₁ F₁ G₁ b f := by
+        constructor
+        · intro x y p hp hxy hrel
+          have left := hPiA.1 hp hxy hrel
+          have hxyB : Γ ⊢ x ≡ y : B₁ := hDom.defeqDF hxy
+          have hrelB : (LR Γ).DefEq x y B₁ p b :=
+            (LR Γ).conv hValDom hrel
+          have right := hPiB.1 hp hxyB hrelB
+          exact ⟨left.leftTy, right.rightTy,
+            left.leftDefEq, right.rightDefEq⟩
+        · intro x p hp hx hrel
+          have left := hPiA.2 hp hx hrel
+          have hxB : Γ ⊢ x : B₁ := hDom.defeqDF hx
+          have hrelB : (LR Γ).DefEq x x B₁ p b :=
+            (LR Γ).conv hValDom hrel
+          have right := hPiB.2 hp hxB hrelB
+          have hCodInst : Γ ⊢ F₁.inst x ≡ G₁.inst x : .sort vCod := by
+            simpa only [SExpr.inst, SExpr.subst] using hCod.subst
+              (Ctx.Subst.one IsDefEq.weakCore IsDefEq.bvar hx)
+          exact ih hΓ hCodInst left right
+      exact ⟨A₁, F₁, B₁, G₁, uDom, vCod,
+        hA₁, hB₁, .single hDom, .single hCod, hValDom, hPi⟩
+
+/-- Compatibility wrapper exposing the conversion handoff from a completed
+joint builder.  The proof itself only needs the positive-bootstrap
+stratified inversion package; keeping that smaller dependency explicit is
+what lets the fixed-head consumer participate in the staged joint tower. -/
+theorem LR.TyDefEq.of_defeq_of_jointBuilder
+    (J : LR.JointBuilder) :
+    ∀ {n : Nat} {Γ : List SExpr} {A B : SExpr} {u : SLevel}
+      {a : WShape n},
+      Ctx.WF Γ →
+      IsDefEq Γ A B (.sort u) →
+      (LR Γ).TyDefEq A A a →
+      (LR Γ).TyDefEq B B a →
+      (LR Γ).TyDefEq A B a :=
+  LR.TyDefEq.of_defeq_of_stratifiedInversion J.stratifiedInversion
+
 theorem LR.Adequate.bot (ha : a.HasType .type) : Adequate Γ₀ Γ ρ M N A .bot a :=
   ⟨fun _ _ _ => ⟨(LR _).bot ha, (LR _).bot ha⟩, fun _ _ => (LR _).bot ha⟩
 
-theorem LR.Adequate.fits
-    (H : ρ.Fits Γ₀ Γ → Adequate Γ₀ Γ ρ M N A m a) : Adequate Γ₀ Γ ρ M N A m a :=
-  ⟨fun _ _ W => (H W.fits).1 W, fun _ W => (H W.fits).2 W⟩
+theorem LR.Adequate.fits
+    (H : ρ.Fits Γ₀ Γ → Adequate Γ₀ Γ ρ M N A m a) : Adequate Γ₀ Γ ρ M N A m a :=
+  ⟨fun _ _ W => (H W.fits).1 W, fun _ W => (H W.fits).2 W⟩
+
+theorem LR.Adequate.refl
+    (H : ∀ {{σ σ'}}, LR.SubstWF Γ₀ σ σ' Γ ρ →
+      (LR Γ₀).DefEq (M.subst σ) (M.subst σ') (A.subst σ) m a) :
+    Adequate Γ₀ Γ ρ M M A m a := ⟨fun _ _ W => ⟨H W, H W⟩, fun _ W => H W⟩
+
+/-- Expose adequacy's two endpoint congruences and its heterogeneous edge as
+one rectangle.  The diagonal is oriented from the left substitution to the
+right substitution: first use same-substitution adequacy on the left, then
+the right-head congruence supplied by the relational substitution.  All
+three edges therefore retain the left-oriented result type required by
+dependent application. -/
+theorem LR.Adequate.rect
+    (H : Adequate Γ₀ Γ ρ M N A m a)
+    (W : LR.SubstWF Γ₀ σ σ' Γ ρ) :
+    LogRel.DefEqRect (LR Γ₀)
+      (M.subst σ) (M.subst σ') (N.subst σ) (N.subst σ')
+      (A.subst σ) m a := by
+  have hcongr := H.1 W
+  exact ⟨hcongr.1, hcongr.2,
+    (LR Γ₀).trans (H.2 W.left) hcongr.2⟩
+
+theorem LR.Adequate.left : Adequate Γ₀ Γ ρ M N A m a → Adequate Γ₀ Γ ρ M M A m a
+  | ⟨h1, _⟩ => .refl fun _ _ W => (h1 W).1
+
+theorem LR.Adequate.symm : Adequate Γ₀ Γ ρ M N A m a → Adequate Γ₀ Γ ρ N M A m a
+  | ⟨h1, h2⟩ => ⟨fun _ _ W => (h1 W).symm, fun _ W => (LR _).symm (h2 W)⟩
+
+theorem LR.Adequate.trans :
+    Adequate Γ₀ Γ ρ M₁ M₂ A m a → Adequate Γ₀ Γ ρ M₂ M₃ A m a → Adequate Γ₀ Γ ρ M₁ M₃ A m a
+  | ⟨a1, a2⟩, ⟨b1, b2⟩ =>
+    ⟨fun _ _ W => ⟨(a1 W).1, (b1 W).2⟩, fun _ W => (LR _).trans (a2 W) (b2 W)⟩
+
+theorem LR.Adequate.trans' : Adequate Γ₀ Γ ρ A₁ A₂ (.sort u) a s →
+    Adequate Γ₀ Γ ρ A₂ A₃ (.sort v) a (.sort r) → Adequate Γ₀ Γ ρ A₁ A₃ (.sort u) a s
+  | ⟨a1, a2⟩, ⟨b1, b2⟩ => by
+    refine ⟨fun σ σ' W => ⟨(a1 W).1, ?_⟩, fun _ W => (LR _).trans' (a2 W) (b2 W)⟩
+    have h1 := (LR _).trans' (a1 W.left).2 (b2 W.left)
+    have h2 := (LR _).trans' (a1 W.symm.left).2 (b2 W.symm.left)
+    exact (LR _).trans ((LR _).symm h1) <| (LR _).trans (a1 W).2 h2
+
+/-- Lower adequacy from a saturated semantic witness to a compatible smaller
+witness.  Constant evaluation recursively builds finite approximants; this
+lemma reconciles the resulting type witnesses through their join. -/
+theorem LR.Adequate.mono_r {Γ₀ Γ : List SExpr} {ρ : Valuation} {M N A : SExpr}
+    {n n' : Nat} {m a : WShape n} {m' a' : WShape n'}
+    (le : m.T ≤ m'.T) (hmem : m.HasType a) (hmem' : m'.HasType a')
+    (hc : a.T.Compat a'.T)
+    (hAty : ∀ {{σ σ'}} (W : LR.SubstWF Γ₀ σ σ' Γ ρ),
+      (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ) a)
+    (hAty' : ∀ {{σ σ'}} (W : LR.SubstWF Γ₀ σ σ' Γ ρ),
+      (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ) a')
+    (H : Adequate Γ₀ Γ ρ M N A m' a') : Adequate Γ₀ Γ ρ M N A m a := by
+  have hJ := TShape.Join.mk hc
+  have ⟨hJ1, hJ2⟩ := (hJ _).1 .rfl
+  have hkn : n ≤ max n n' := Nat.le_max_left ..
+  have hkn' : n' ≤ max n n' := Nat.le_max_right ..
+  have hjk : (a.T.join a'.T).1 ≤ max n n' := Nat.max_le.2 ⟨hkn, hkn'⟩
+  have hJ1' := (TShape.LE.def hkn hjk).1 hJ1
+  have hJ2' := (TShape.LE.def hkn' hjk).1 hJ2
+  have hJ_t := (TShape.HasType.sort_r.2 hmem.isType).join' hJ
+    (TShape.HasType.sort_r.2 hmem'.isType)
+  have hmem_k := (WShape.HasType.lift hkn).2 hmem
+  have hmem'_k := (WShape.HasType.lift hkn').2 hmem'
+  have hJ_t' := TShape.HasType.sort_r.1 <|
+    hJ_t.mono_l (TShape.lift_eqv hjk).2 (TShape.lift_eqv hjk).1
+  have lower : ∀ {M₀ N₀ : SExpr} {{σ σ'}} (W : LR.SubstWF Γ₀ σ σ' Γ ρ),
+      (LR Γ₀).DefEq M₀ N₀ (A.subst σ) m' a' →
+      (LR Γ₀).DefEq M₀ N₀ (A.subst σ) m a := by
+    intro M₀ N₀ σ σ' W hv
+    have ha_kty : (WShape.lift (max n n') a).HasType .type := by
+      simpa using (WShape.HasType.lift hkn).2 hmem.isType
+    have ha'_kty : (WShape.lift (max n n') a').HasType .type := by
+      simpa using (WShape.HasType.lift hkn').2 hmem'.isType
+    have tyJ := (LR Γ₀).join_ty ((TShape.Compat.def hkn hkn').2 hc) ha_kty ha'_kty
+      ((TyDefEq.lift hkn hmem.isType).2 (hAty W))
+      ((TyDefEq.lift hkn' hmem'.isType).2 (hAty' W))
+    have tyJ' : (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ)
+        ((a.T.join a'.T).snd.lift (max n n')) := WShape.lift_self ▸ tyJ
+    refine (DefEq.lift hkn hmem).1 <| (LR Γ₀).mono_r_2 hJ1' hmem_k hJ_t' <|
+      (LR Γ₀).mono_l ((TShape.LE.def hkn hkn').1 le)
+        (.mono_r hJ1' hJ_t' hmem_k) (.mono_r hJ2' hJ_t' hmem'_k) <|
+      (LR Γ₀).mono_r_1 hJ2' hmem'_k (.mono_r hJ2' hJ_t' hmem'_k) tyJ' <|
+        (DefEq.lift hkn' hmem').2 hv
+  exact ⟨fun σ σ' W => ⟨lower W (H.1 W).1, lower W (H.1 W).2⟩,
+    fun σ W => lower W (H.2 W)⟩
+
+theorem LR.Adequate.cons
+    (ihA : ∀ {ρ n} {m a : WShape n}, LE_Interp ρ m.T A → LE_Interp ρ a.T (.sort u) →
+      m.HasType a → Adequate Γ₀ Γ ρ A A' (sort u) m a)
+    (HA : IsDefEqStrong Γ A A' (.sort u))
+    {{k : Nat}} {{a₁ p : WShape k}} {{x x' σ σ' ρ}}
+    (hp : p.HasType a₁) (hA₁ : LE_Interp ρ a₁.T A)
+    (hx : Γ₀ ⊢ x ≡ x' : A.subst σ) (hv : (LR Γ₀).DefEq x x' (A.subst σ) p a₁)
+    (W : SubstWF Γ₀ σ σ' Γ ρ) : SubstWF Γ₀ (σ.cons x) (σ'.cons x') (A :: Γ) (ρ.push p.T) := by
+  refine W.cons (fun hA => ?_) hA₁ hp.T HA.defeq.hasType.1 ⟨hx, fun n a' ha' => ?_⟩
+  · have ⟨_, _, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.fits).2 hA
+    exact ⟨_, le_a, hA', (TShape.HasType.mono_r hSort.le_sort .sort hmem').toType⟩
+  have ha' := LE_Interp.weak_iff.1 ha'
+  refine ⟨fun ht => ⟨⟨_, (HA.substCongr W.toSubstEq).1⟩, ?_⟩, fun m' hm' ht => ?_⟩
+  · have ⟨_, _, _, le_n, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.fits).2 ha' |>.out
+    refine (TyDefEq.lift le_n ht).1 <| (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
+      (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht)
+      (WShape.HasType.mono_r hSort.le_sort' .sort hmem').toType ?_
+    exact (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
+      (.mono_r hSort.le_sort' .sort hmem') .sort ((ihA hA' hSort hmem').1 W).1
+  · have le_k := Nat.le_max_left k n; have le_n := Nat.le_max_right k n
+    have ht' := (WShape.HasType.lift le_n).2 ht
+    have hp' := (WShape.HasType.lift le_k).2 hp
+    have hle' := (TShape.LE.def le_n le_k).1 (LE_Interp.bvar_iff.1 hm')
+    have hta₁ := WShape.lift_type ▸ (WShape.HasType.lift le_k).2 hp.isType
+    have hta' := WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht.isType
+    have hc := hA₁.compat ha'
+    have hj := (TShape.Join.def le_k le_n (Nat.le_refl _)).1 (.mk hc)
+    rw [TShape.lift_join le_k le_n] at hj
+    have ⟨hj1, hj2⟩ := hj.le
+    have hJ := hta₁.join' hj hta'
+    have hJ' := hJ.mono_r hj1 hp'
+    refine (DefEq.lift le_n ht).1 <|
+      (LR Γ₀).mono_r_2 hj2 ht' hJ <|
+      (LR Γ₀).mono_l hle' (hJ.mono_r hj2 ht') hJ' <|
+      (LR Γ₀).mono_r_1 hj1 hp' hJ' ?_ <| (DefEq.lift le_k hp).2 hv
+    have valTyA {nd : Nat} {a : WShape nd} (hA : LE_Interp ρ a.T A) (ha : a.HasType .type) :
+        (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ) a :=
+      have ⟨_, _, _, le_n, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.left.fits).2 hA |>.out
+      have v2 := (ihA hA' hSort hmem').2 W.left
+      have vt := (LR Γ₀).left_ty <| (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
+        (.mono_r hSort.le_sort' .sort hmem') .sort v2
+      (TyDefEq.lift le_n ha).1 <| (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
+        (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ha)
+        (WShape.HasType.mono_r hSort.le_sort' .sort hmem').toType vt
+    refine (LR Γ₀).join_ty ((TShape.Compat.def le_k le_n).2 hc) hta₁ hta' ?_ ?_
+    · exact (TyDefEq.lift le_k hp.isType).2 (valTyA hA₁ hp.isType)
+    · exact (TyDefEq.lift le_n ht.isType).2 (valTyA ha' ht.isType)
+
+/-- Extract `TyDefEq` from a `DefEq` at sort type. -/
+theorem LR.toValTy {m : WShape n'} {b : WShape n} (le_n : n ≤ n') (le_a : b.T ≤ m.T)
+    (ht : b.HasType .type) (hSort : LE_Interp ρ a.T (.sort u)) (hmem' : m.HasType a)
+    (H : (LR Γ₀).DefEq M N (.sort u) m a) : (LR Γ₀).TyDefEq M N b := by
+  have hle := hSort.le_sort'
+  refine (LR.TyDefEq.lift le_n ht).1 ?_
+  refine (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
+    (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht)
+    (WShape.HasType.mono_r hle .sort hmem').toType ?_
+  exact (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hle hmem'
+    (.mono_r hle .sort hmem') .sort H
+
+/-- One function layer of constant evaluation.  The continuation receives
+the original strictly smaller semantic branch together with the input and
+output bounds that select it.  Keeping that provenance explicit lets the
+caller recurse on the actual `Const.lam` child rather than on a reconstructed
+`lift`/`mono` proof of equal depth. -/
+theorem LR.constLamDefEq
+    {n n' nArgs : Nat} {f : WShapeFun n} {f' : WShapeFun n'} {hf : f.NonZero}
+    {M N : SExpr}
+    {a₁ : WShape n} {a₂ : WShapeFun n}
+    {A₁ A₂ : SExpr}
+    (htm : WShape.HasTypeLam f a₁ a₂)
+    (hlam : (WShape.lam' f).T ≤ (WShape.lam' f').T)
+    (eval : ∀ {x y : SExpr} {p : WShape (max n nArgs)}
+      {x₀ y₀ : WShape n'},
+      p.HasType (a₁.lift (max n nArgs)) →
+      Γ₀ ⊢ x ≡ y : A₁ →
+      (LR Γ₀).DefEq x y A₁ p (a₁.lift (max n nArgs)) →
+      (x₀, y₀) ∈ f' → x₀.T ≤ p.T →
+      ((f.lift (max n nArgs)).app p).T ≤ y₀.T →
+      LogRel.DefEqRect (LR Γ₀)
+        (M.app x) (M.app y) (N.app x) (N.app y)
+        (A₂.inst x) ((f.lift (max n nArgs)).app p)
+          ((a₂.lift (max n nArgs)).app p)) :
+    LRS.LamDefEq (LR Γ₀) M N A₁ A₂ f a₁ a₂ := by
+  let k := max n nArgs
+  have hn : n ≤ k := Nat.le_max_left ..
+  have hnArgs : nArgs ≤ k := Nat.le_max_right ..
+  have childBounds (p : WShape n) :
+      ∃ x₀ y₀ : WShape n', (x₀, y₀) ∈ f' ∧
+        x₀.T ≤ p.T ∧ (f.app p).T ≤ y₀.T := by
+    let K := max n n'
+    have hnK : n ≤ K := Nat.le_max_left ..
+    have hn'K : n' ≤ K := Nat.le_max_right ..
+    have hffT : TShapeFun.LE f f' := TShape.LE.lam'_decomp hlam
+    have hff : f.lift K ≤ f'.lift K :=
+      (TShapeFun.LE.def hnK hn'K).1 hffT
+    obtain ⟨x, hx, hmem⟩ := (f.lift K).app_eq (p.lift K)
+    obtain ⟨x', y', hmem', hx', hy'⟩ :=
+      WShapeFun.LE.def'.1 hff _ _ hmem
+    obtain ⟨x₀, y₀, hmem₀, rfl, rfl⟩ :=
+      (WShapeFun.mem_lift hn'K).1 hmem'
+    have hxT : x₀.T ≤ p.T :=
+      (TShape.lift_eqv hn'K).2 |>.trans
+        ((hx'.trans hx).T) |>.trans (TShape.lift_eqv hnK).1
+    have hyLift : (f.app p).lift K ≤ y₀.lift K := by
+      simpa only [WShapeFun.lift_app hnK] using hy'
+    have hyT : (f.app p).T ≤ y₀.T :=
+      (TShape.lift_eqv hnK).2 |>.trans hyLift.T |>.trans
+        (TShape.lift_eqv hn'K).1
+    exact ⟨x₀, y₀, hmem₀, hxT, hyT⟩
+  have lower {x y : SExpr} {p : WShape n}
+      (hp : p.HasType a₁) (hxy : Γ₀ ⊢ x ≡ y : A₁)
+      (hv : (LR Γ₀).DefEq x y A₁ p a₁) :
+      LogRel.DefEqRect (LR Γ₀)
+        (M.app x) (M.app y) (N.app x) (N.app y)
+        (A₂.inst x) (f.app p) (a₂.app p) := by
+    have hpₖ : (p.lift k).HasType (a₁.lift k) :=
+      (WShape.HasType.lift hn).2 hp
+    have hvₖ : (LR Γ₀).DefEq x y A₁ (p.lift k) (a₁.lift k) :=
+      (LR.DefEq.lift hn hp).2 hv
+    obtain ⟨x₀, y₀, hmem₀, hx₀, hy₀⟩ := childBounds p
+    have hy₀k : ((f.lift k).app (p.lift k)).T ≤ y₀.T := by
+      rw [← WShapeFun.lift_app hn]
+      exact (TShape.lift_eqv hn).1.trans hy₀
+    have hout := eval hpₖ hxy hvₖ hmem₀
+      (hx₀.trans (TShape.lift_eqv hn).2) hy₀k
+    have lowerEdge {P Q : SExpr}
+        (H : (LR Γ₀).DefEq P Q (A₂.inst x)
+          ((f.lift k).app (p.lift k)) ((a₂.lift k).app (p.lift k))) :
+        (LR Γ₀).DefEq P Q (A₂.inst x) (f.app p) (a₂.app p) := by
+      have H' : (LR Γ₀).DefEq P Q (A₂.inst x)
+          ((f.app p).lift k) ((a₂.app p).lift k) := by
+        simpa only [WShapeFun.lift_app hn] using H
+      exact (LR.DefEq.lift hn
+        ((WShape.HasTypeLam.iff.1 htm).2.2 p hp)).1 H'
+    exact ⟨lowerEdge hout.left, lowerEdge hout.right, lowerEdge hout.cross⟩
+  refine ⟨fun _ _ _ hp hxy hv => ?_, fun _ _ hp hx hv => ?_⟩
+  · have H := lower hp hxy hv
+    exact ⟨H.left, H.right⟩
+  · exact (lower hp hx hv).cross
+
+/-- The final semantic application carried by the constant evaluator.  This
+packages the raw final-Pi spine together with the *same* logical-relation
+argument witness and Pi edge.  Keeping these fields in one dependent record
+prevents the reached iota leaf from forgetting that the constructor major is
+related at the domain used by the recursor application. -/
+structure LR.PatternLeafSpine (Γ : List SExpr) (IH : LogRel Γ n)
+    (Head : SExpr) (args args' : List SExpr) (rargs : List (WShape n))
+    (A : SExpr) (out outTy : WShape n) where
+  majorX : SExpr
+  recXs : List SExpr
+  majorY : SExpr
+  recYs : List SExpr
+  majorShape : WShape n
+  recShapes : List (WShape n)
+  majorTypeShape : WShape n
+  resultShape : WShapeFun n
+  resultTypeShape : WShapeFun n
+  args_eq : args = majorX :: recXs
+  args'_eq : args' = majorY :: recYs
+  rargs_eq : rargs = majorShape :: recShapes
+  out_eq : out = resultShape.app majorShape
+  outTy_eq : outTy = resultTypeShape.app majorShape
+  pair : SExpr.SpineWF.LastPair Γ Head recXs recYs majorX majorY A
+  majorHasType : majorShape.HasType majorTypeShape
+  resultType : WShape.HasTypePi resultTypeShape majorTypeShape true
+  majorType : IH.TyDefEq pair.domain pair.domain majorTypeShape
+  majorRel : IH.DefEq majorX majorY pair.domain majorShape majorTypeShape
+  aligned : LRS.CtorSpineDefEq IH Head args args' rargs A
+  pi : LRS.PiDefEq IH pair.domain pair.codomain pair.codomain
+    majorTypeShape resultTypeShape
+
+/-- Forget the final-Pi alignment back to the ordinary related argument
+spine consumed by the structural constant cases. -/
+theorem LR.PatternLeafSpine.args
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    LRS.CtorArgsDefEq IH xs ys rargs := H.aligned.args
+
+/-- Recover the common raw type of the two majors from an externally
+decomposed nonempty leaf.  Destructing the package before transporting its
+major equality avoids dependent rewrites through the `LastPair` projection. -/
+theorem LR.PatternLeafSpine.majorDefEq
+    (H : LR.PatternLeafSpine Γ IH Head (x :: xs) (y :: ys)
+      rargs A out outTy) :
+    ∃ D, IsDefEq Γ x y D := by
+  rcases H with ⟨mx, _, my, _, _, _, _, _, _, hx, hy, _, _, _, pair, _, _⟩
+  have hmx : x = mx := (List.cons.inj hx).1
+  have hmy : y = my := (List.cons.inj hy).1
+  subst mx
+  subst my
+  exact ⟨pair.domain, pair.major⟩
+
+/-- A packaged final application is definitionally nonempty. -/
+theorem LR.PatternLeafSpine.nonempty
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    rargs ≠ [] := by
+  rw [H.rargs_eq]
+  simp
+
+/-- Keep the left concrete spine at both endpoints.  The final application
+certificate was deliberately designed to retain both prefix and major
+self-relations, so this operation is structural. -/
+def LR.PatternLeafSpine.left
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    LR.PatternLeafSpine Γ IH Head xs xs rargs A out outTy :=
+  { H with
+    majorY := H.majorX
+    recYs := H.recXs
+    args'_eq := H.args_eq
+    pair := H.pair.leftPrefixes.leftMajors
+    majorRel := IH.left H.majorRel
+    aligned := H.aligned.left }
+
+/-- Keep the right concrete spine at both endpoints. -/
+def LR.PatternLeafSpine.right
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    LR.PatternLeafSpine Γ IH Head ys ys rargs A out outTy :=
+  { H with
+    majorX := H.majorY
+    recXs := H.recYs
+    args_eq := H.args'_eq
+    pair := H.pair.rightPrefixes.rightMajors
+    majorRel := IH.left (IH.symm H.majorRel)
+    aligned := H.aligned.right }
+
+/-- Keep the related final majors while using the left recursor prefix at
+both endpoints.  This is the left row of the synchronized iota rectangle;
+unlike `left`, it does not replace the right major by the left major. -/
+def LR.PatternLeafSpine.leftPrefixes
+    {majorX majorY : SExpr} {recXs recYs : List SExpr}
+    {majorShape : WShape n} {recShapes : List (WShape n)}
+    (H : LR.PatternLeafSpine Γ IH Head
+      (majorX :: recXs) (majorY :: recYs)
+      (majorShape :: recShapes) A out outTy) :
+    LR.PatternLeafSpine Γ IH Head
+      (majorX :: recXs) (majorY :: recXs)
+      (majorShape :: recShapes) A out outTy := by
+  rcases H with
+    ⟨mx, rxs, my, rys, ms, rss, mts, rs, rts,
+      hargs, hargs', hrargs, hout, houtTy, pair,
+      hmsty, hrty, hmty, hmrel, haligned, hpi⟩
+  simp only [List.cons.injEq] at hargs hargs' hrargs
+  rcases hargs with ⟨rfl, rfl⟩
+  rcases hargs' with ⟨rfl, rfl⟩
+  rcases hrargs with ⟨rfl, rfl⟩
+  exact {
+    majorX := majorX
+    recXs := recXs
+    majorY := majorY
+    recYs := recXs
+    majorShape := majorShape
+    recShapes := recShapes
+    majorTypeShape := mts
+    resultShape := rs
+    resultTypeShape := rts
+    args_eq := rfl
+    args'_eq := rfl
+    rargs_eq := rfl
+    out_eq := hout
+    outTy_eq := houtTy
+    pair := pair.leftPrefixes
+    majorHasType := hmsty
+    resultType := hrty
+    majorType := hmty
+    majorRel := hmrel
+    aligned := haligned.leftPrefixes
+    pi := hpi }
+
+/-- Keep the related final majors while using the right recursor prefix at
+both endpoints.  This is the right row of the synchronized iota rectangle. -/
+def LR.PatternLeafSpine.rightPrefixes
+    {majorX majorY : SExpr} {recXs recYs : List SExpr}
+    {majorShape : WShape n} {recShapes : List (WShape n)}
+    (H : LR.PatternLeafSpine Γ IH Head
+      (majorX :: recXs) (majorY :: recYs)
+      (majorShape :: recShapes) A out outTy) :
+    LR.PatternLeafSpine Γ IH Head
+      (majorX :: recYs) (majorY :: recYs)
+      (majorShape :: recShapes) A out outTy := by
+  rcases H with
+    ⟨mx, rxs, my, rys, ms, rss, mts, rs, rts,
+      hargs, hargs', hrargs, hout, houtTy, pair,
+      hmsty, hrty, hmty, hmrel, haligned, hpi⟩
+  simp only [List.cons.injEq] at hargs hargs' hrargs
+  rcases hargs with ⟨rfl, rfl⟩
+  rcases hargs' with ⟨rfl, rfl⟩
+  rcases hrargs with ⟨rfl, rfl⟩
+  exact {
+    majorX := majorX
+    recXs := recYs
+    majorY := majorY
+    recYs := recYs
+    majorShape := majorShape
+    recShapes := recShapes
+    majorTypeShape := mts
+    resultShape := rs
+    resultTypeShape := rts
+    args_eq := rfl
+    args'_eq := rfl
+    rargs_eq := rfl
+    out_eq := hout
+    outTy_eq := houtTy
+    pair := pair.rightPrefixes
+    majorHasType := hmsty
+    resultType := hrty
+    majorType := hmty
+    majorRel := hmrel
+    aligned := haligned.rightPrefixes
+    pi := hpi }
+
+/-- Swap both concrete spines while retaining the left-oriented result type. -/
+def LR.PatternLeafSpine.symm
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    LR.PatternLeafSpine Γ IH Head ys xs rargs A out outTy :=
+  { H with
+    majorX := H.majorY
+    recXs := H.recYs
+    majorY := H.majorX
+    recYs := H.recXs
+    args_eq := H.args'_eq
+    args'_eq := H.args_eq
+    pair := H.pair.symm
+    majorRel := IH.symm H.majorRel
+    aligned := H.aligned.symm }
+
+/-- Transport a packaged final application through the same lift equivalence
+used by a normalized constructor frame. -/
+def LR.PatternLeafSpine.lift
+    {IH : LogRel Γ n} {IH' : LogRel Γ n'} (le : n ≤ n')
+    (E : LogRel.LiftEquiv IH IH' le)
+    (H : LR.PatternLeafSpine Γ IH Head xs ys rargs A out outTy) :
+    LR.PatternLeafSpine Γ IH' Head xs ys (rargs.map (.lift n')) A
+      (out.lift n') (outTy.lift n') := by
+  have hmajorType : IH'.TyDefEq H.pair.domain H.pair.domain
+      (H.majorTypeShape.lift n') :=
+    (E.ty H.majorHasType.isType).2 H.majorType
+  have hmajorRel : IH'.DefEq H.majorX H.majorY H.pair.domain
+      (H.majorShape.lift n') (H.majorTypeShape.lift n') :=
+    (E.term H.majorHasType).2 H.majorRel
+  exact {
+    majorX := H.majorX
+    recXs := H.recXs
+    majorY := H.majorY
+    recYs := H.recYs
+    majorShape := H.majorShape.lift n'
+    recShapes := H.recShapes.map (.lift n')
+    majorTypeShape := H.majorTypeShape.lift n'
+    resultShape := H.resultShape.lift n'
+    resultTypeShape := H.resultTypeShape.lift n'
+    args_eq := H.args_eq
+    args'_eq := H.args'_eq
+    rargs_eq := by simpa only [H.rargs_eq, List.map_cons]
+    out_eq := by simpa only [H.out_eq, WShapeFun.lift_app le]
+    outTy_eq := by simpa only [H.outTy_eq, WShapeFun.lift_app le]
+    pair := H.pair
+    majorHasType := (WShape.HasType.lift le).2 H.majorHasType
+    resultType := (WShape.HasTypePi.lift le).2 H.resultType
+    majorType := hmajorType
+    majorRel := hmajorRel
+    aligned := H.aligned.lift le E.ty E.term
+    pi := (LRS.PiDefEq.liftEquiv le H.resultType E).2 H.pi }
+
+/-- The remaining consumer obligation at a reached nonempty pattern leaf. -/
+def LR.PatternLeafDefEq (Γ₀ : List SExpr) (c : Name) (ls : List SLevel)
+    (R : TShape → SExpr → Prop) : Prop :=
+  ∀ {n : Nat} {rargs : List (WShape n)}
+      {p : Pattern} {r : p.RHS × p.Check} {mcap : p.Path → TShape}
+      {xs ys : List SExpr} {CHead A : SExpr} {out outTy : WShape n},
+      Params.Pat p r →
+      LE_Interp.Matches (n := n) p c rargs mcap →
+      LE_Interp.RHS ls mcap R out.T r.1 →
+      LR.PatternLeafSpine Γ₀ (LR Γ₀) CHead xs ys rargs A out outTy →
+      Γ₀ ⊢
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ≡
+        (ys.foldr (fun a f => f.app a) (.const c ls)) : A →
+      (∃ u, Γ₀ ⊢ A : .sort u) →
+      Γ₀ ⊢ .const c ls : CHead →
+      SExpr.SpineWF Γ₀ CHead xs.reverse A →
+      SExpr.SpineWF Γ₀ CHead ys.reverse A →
+      out.HasType outTy →
+      (LR Γ₀).TyDefEq A A outTy →
+      (LR Γ₀).DefEq
+        (xs.foldr (fun a f => f.app a) (.const c ls))
+        (ys.foldr (fun a f => f.app a) (.const c ls)) A out outTy
+
+/-- The nonempty leaf contract after eliminating the impossible definition
+case.  Its pattern is definitionally an iota pattern, so consumers can invert
+the semantic match into recursor and constructor spines without another
+shape oracle. -/
+def LR.IotaLeafDefEq (Γ₀ : List SExpr) (c : Name) (ls : List SLevel)
+    (R : TShape → SExpr → Prop) : Prop :=
+  ∀ {n : Nat} {rargs : List (WShape n)}
+      {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      {mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape}
+      {xs ys : List SExpr} {CHead A : SExpr} {out outTy : WShape n},
+      Params.Pat (RecursorIotaPattern rec major ctor arity) r →
+      LE_Interp.Matches (n := n) (RecursorIotaPattern rec major ctor arity)
+        c rargs mcap →
+      LE_Interp.RHS ls mcap R out.T r.1 →
+      LR.PatternLeafSpine Γ₀ (LR Γ₀) CHead xs ys rargs A out outTy →
+      Γ₀ ⊢
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ≡
+        (ys.foldr (fun a f => f.app a) (.const c ls)) : A →
+      (∃ u, Γ₀ ⊢ A : .sort u) →
+      Γ₀ ⊢ .const c ls : CHead →
+      SExpr.SpineWF Γ₀ CHead xs.reverse A →
+      SExpr.SpineWF Γ₀ CHead ys.reverse A →
+      out.HasType outTy →
+      (LR Γ₀).TyDefEq A A outTy →
+      (LR Γ₀).DefEq
+      (xs.foldr (fun a f => f.app a) (.const c ls))
+      (ys.foldr (fun a f => f.app a) (.const c ls)) A out outTy
+
+/-- One reached iota leaf at an explicit logical argument-spine level. -/
+def LR.IotaLeafDefEqAt (Γ₀ : List SExpr) (level : Nat)
+    (c : Name) (ls : List SLevel)
+    (R : TShape → SExpr → Prop) : Prop :=
+  ∀ {rargs : List (WShape level)}
+      {rec : Name} {major : Nat} {ctor : Name} {arity : Nat}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      {mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape}
+      {xs ys : List SExpr} {CHead A : SExpr}
+      {out outTy : WShape level},
+      Params.Pat (RecursorIotaPattern rec major ctor arity) r →
+      LE_Interp.Matches (n := level)
+        (RecursorIotaPattern rec major ctor arity) c rargs mcap →
+      LE_Interp.RHS ls mcap R out.T r.1 →
+      LR.PatternLeafSpine Γ₀ (LR Γ₀) CHead xs ys rargs A out outTy →
+      Γ₀ ⊢
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ≡
+        (ys.foldr (fun a f => f.app a) (.const c ls)) : A →
+      (∃ u, Γ₀ ⊢ A : .sort u) →
+      Γ₀ ⊢ .const c ls : CHead →
+      SExpr.SpineWF Γ₀ CHead xs.reverse A →
+      SExpr.SpineWF Γ₀ CHead ys.reverse A →
+      out.HasType outTy →
+      (LR Γ₀).TyDefEq A A outTy →
+      (LR Γ₀).DefEq
+        (xs.foldr (fun a f => f.app a) (.const c ls))
+        (ys.foldr (fun a f => f.app a) (.const c ls)) A out outTy
+
+/-- The structural pattern-leaf contract at one explicit spine level. -/
+def LR.PatternLeafDefEqAt (Γ₀ : List SExpr) (level : Nat)
+    (c : Name) (ls : List SLevel)
+    (R : TShape → SExpr → Prop) : Prop :=
+  ∀ {rargs : List (WShape level)}
+      {p : Pattern} {r : p.RHS × p.Check} {mcap : p.Path → TShape}
+      {xs ys : List SExpr} {CHead A : SExpr}
+      {out outTy : WShape level},
+      Params.Pat p r →
+      LE_Interp.Matches (n := level) p c rargs mcap →
+      LE_Interp.RHS ls mcap R out.T r.1 →
+      LR.PatternLeafSpine Γ₀ (LR Γ₀) CHead xs ys rargs A out outTy →
+      Γ₀ ⊢
+        (xs.foldr (fun a f => f.app a) (.const c ls)) ≡
+        (ys.foldr (fun a f => f.app a) (.const c ls)) : A →
+      (∃ u, Γ₀ ⊢ A : .sort u) →
+      Γ₀ ⊢ .const c ls : CHead →
+      SExpr.SpineWF Γ₀ CHead xs.reverse A →
+      SExpr.SpineWF Γ₀ CHead ys.reverse A →
+      out.HasType outTy →
+      (LR Γ₀).TyDefEq A A outTy →
+      (LR Γ₀).DefEq
+        (xs.foldr (fun a f => f.app a) (.const c ls))
+        (ys.foldr (fun a f => f.app a) (.const c ls)) A out outTy
+
+/-- A fixed-level iota handler discharges the corresponding structural
+nonempty pattern leaf. -/
+theorem LR.PatternLeafDefEqAt.of_iota
+    (H : LR.IotaLeafDefEqAt Γ₀ level c ls R) :
+    LR.PatternLeafDefEqAt Γ₀ level c ls R := by
+  intro rargs p r mcap xs ys CHead A out outTy
+    hpat hmatch hrhs hleaf hterm hAType hhead hspineX hspineY hout hA
+  obtain ⟨rec, major, ctor, arity, rfl⟩ :=
+    hmatch.iota_of_pat_nonempty hpat hleaf.nonempty
+  exact H hpat hmatch hrhs hleaf hterm hAType hhead
+    hspineX hspineY hout hA
+
+/-- The witness-aware iota obligation at the exact constant-argument level. -/
+def LR.IotaWitnessStepAt (Γ₀ : List SExpr) (level : Nat) : Prop :=
+  Ctx.WF Γ₀ →
+  ∀ {ρ : Valuation} {c : Name} {ls : List SLevel}
+      {R : TShape → SExpr → Prop},
+    (∀ {m M}, R m M → LE_Interp.Witness ρ m M) →
+    LR.IotaLeafDefEqAt Γ₀ level c ls (LE_Interp.Lower R)
+
+/-- The sole recursive semantic input needed by the nonempty iota leaf.
+
+Keeping this boundary separate from derivation induction lets the joint
+level construction provide predecessor uniqueness and fixed-head recursion
+without assuming the polymorphic adequacy theorem being assembled. -/
+def LR.IotaWitnessStep (Γ₀ : List SExpr) : Prop :=
+  Ctx.WF Γ₀ →
+  ∀ {ρ : Valuation} {c : Name} {ls : List SLevel}
+      {R : TShape → SExpr → Prop},
+    (∀ {m M}, R m M → LE_Interp.Witness ρ m M) →
+    LR.IotaLeafDefEq Γ₀ c ls (LE_Interp.Lower R)
+
+/-- The depth-indexed joint-leaf obligation.  At rung `depth` of the
+stratified adequacy fixpoint, the recursive constructor-major leaf may
+consume every strictly smaller contextual adequacy rung; the fixpoint
+itself never assembles a predecessor inversion or uniqueness package on
+the leaf's behalf.  Shape levels stay polymorphic inside the produced
+`IotaWitnessStep`: only the adequacy rung is indexed, so no
+level-indexed obligation is reintroduced.
+
+The strict predecessor family is stated in exactly the shape of the two
+prepared consumers at a successor rung:
+`JointStratifiedPathInversionAt.of_predecessorAdequacy` at the
+predecessor depth, and `SelfAdequateDefeqStepAt.of_lowerAdequacy` at any
+interior depth of the coherent construction. -/
+def LR.IotaWitnessStepAtDepth (Γ₀ : List SExpr) (depth : Nat) : Prop :=
+  (∀ d', d' < depth → LR.ContextualAdequacyAtDepth d') →
+  LR.IotaWitnessStep Γ₀
+
+/-- The depth-indexed joint-leaf obligation uniformly over target
+contexts.  `Ctx.WF Γ₀` is already the first argument of the produced
+`IotaWitnessStep`, so no separate well-formedness hypothesis is repeated
+here. -/
+def LR.ContextualIotaWitnessStepAtDepth (depth : Nat) : Prop :=
+  ∀ {Γ₀ : List SExpr}, LR.IotaWitnessStepAtDepth Γ₀ depth
+
+/-- The synchronized producer certificate for one generated fixed-head
+application chain.
+
+The `TypedTelescope` component records the semantic term spine, its dependent
+type spine, and the exact terminal type observation.  `Captures` pins every
+application layer to the same aligned logical-relation representative used
+as its semantic upper bound and as its typed domain argument.  This is the
+non-erasing boundary required before the fixed-head application fold: none
+of the three components may independently reselect an existential capture. -/
+def LR.FixedHeadTelescope (Γ₀ : List SExpr)
+    {p : Pattern} {mcap : p.Path → TShape}
+    (mx my captureType : p.Path → SExpr)
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out) : Prop :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures
+    (m2 := mcap)
+    (fun {n} path (elemShape typeShape : WShape n) =>
+      LRS.CaptureDefEqAligned.AtShapes (LR Γ₀)
+        (mcap path) (mx path) (my path) (captureType path)
+        elemShape typeShape)
+    head paths out headTy outTy
+
+/-- One application layer of the synchronized peel (the N1 core, ported
+verbatim from the proved probe `probeB.peelLayerProved`).  Given the next
+layer's synchronized lower endpoint below `g.app aSp`, an aligned capture
+bound `aSp ≤ argCap` typed in the literal domain, and the layer's lambda
+typing, produce the synchronized lower endpoint one layer earlier: a
+singleton lambda at the typed fire point, typed by the singleton Pi at
+that same fire point, below the literal `forallE tyDom tyFun`
+observation.  `hgle` and `hty` are unused by this layer's algebra but fix
+the interface of the spine recursion that will consume it. -/
+theorem WShape.HasTypeLam.peelLayer
+    {n : Nat} {g g' : WShapeFun n}
+    {tyDom : WShape n} {tyFun : WShapeFun n}
+    (hgle : g ≤ g')
+    (hty : WShape.HasTypeLam g' tyDom tyFun)
+    {aSp argCap : WShape n}
+    (hargCap : aSp ≤ argCap)
+    (hcapDom : argCap.HasType tyDom)
+    {next nextTy : WShape n}
+    (hnext : next ≤ g.app aSp)
+    (hnextTy : next.HasType nextTy)
+    (hnextLe : nextTy ≤ tyFun.app argCap) :
+    ∃ elem elemTy : WShape (n + 1),
+      elem ≤ .lam' g ∧ elem.HasType elemTy ∧
+        elemTy ≤ .forallE tyDom tyFun := by
+  refine ⟨.lam' (.single argCap next), .forallE tyDom (.single argCap nextTy),
+    ?_, ?_, ?_⟩
+  · -- elem ≤ lam' g : one dominating pair of g at the typed fire point
+    apply WShape.lam'_le_lam'.2
+    obtain ⟨x', hx', hmem⟩ := g.app_eq argCap
+    exact WShapeFun.single_le.2
+      ⟨x', _, hmem, hx', hnext.trans (WShapeFun.app_mono_r hargCap)⟩
+  · -- elem.HasType elemTy : singleton lambda typing at the REAL domain
+    apply WShape.HasType.lam
+    refine WShape.HasTypeLam.iff'.2 ⟨?_, ?_, fun x => ?_⟩
+    · refine WShape.HasTypePi.def.2
+        ⟨WShape.HasDom.single.2 (.inl hcapDom), ?_⟩
+      intro x y hxy
+      obtain ⟨rfl, rfl⟩ | ⟨_, rfl, rfl⟩ := WShapeFun.mem_single.1 hxy
+      · exact hnextTy.isType
+      · exact .bot' .sort
+    · exact WShape.HasDom.single.2 (.inl hcapDom)
+    · simp only [WShapeFun.single_app]
+      split <;> [exact hnextTy; exact .bot' (.bot' .sort)]
+  · -- elemTy ≤ forallE tyDom tyFun : domain is literal; fun by one pair
+    apply WShape.forallE_le_forallE.2
+    refine ⟨.rfl, ?_⟩
+    obtain ⟨x', hx', hmem⟩ := tyFun.app_eq argCap
+    exact WShapeFun.single_le.2 ⟨x', _, hmem, hx', hnextLe⟩
+
+/-- Empty fixed-head telescope.  Its initial and terminal type observations
+are definitionally the supplied result type. -/
+theorem LR.FixedHeadTelescope.nil
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr} {head outTy : TShape}
+    (htyped : head.HasType outTy) :
+    LR.FixedHeadTelescope (headTy := outTy) (outTy := outTy)
+      Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.nil (m2 := mcap) (head := head)) := by
+  exact LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.nil htyped
+
+/-- Prepend one synchronized application layer.
+
+The aligned capture's exact element shape is reused as `argCap`; hence the
+semantic spine argument lies below it, it is typed in the literal domain of
+the constructed Pi observation, and the logical capture relation remains
+indexed by that same pair. -/
+theorem LR.FixedHeadTelescope.cons
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+    {m out : TShape} {path : p.Path} {paths : List p.Path}
+    (harg : a.T ≤ mcap path) (happ : m ≤ (f.app a).T)
+    (rest : LE_Interp.RHS.ShapeSpine mcap m paths out)
+    {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+    {outTy : TShape}
+    (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ₀)
+      (mcap path) (mx path) (my path) (captureType path)
+      argCap tyDom)
+    (tail : LR.FixedHeadTelescope
+      (headTy := (tyFun.app argCap).T) (outTy := outTy)
+      Γ₀ mx my captureType rest) :
+    LR.FixedHeadTelescope
+      (headTy := (WShape.forallE tyDom tyFun).T) (outTy := outTy)
+      Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.cons harg happ rest) := by
+  have hargCap : a ≤ argCap :=
+    WShape.LE.T_iff.1 (harg.trans capture.1)
+  exact LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.cons
+    harg happ hargCap capture.2.1 capture tail
+
+/-- Forget the logical capture payload and recover the synchronized lower
+head selected by the ordered term/type telescope. -/
+theorem LR.FixedHeadTelescope.lowerHead
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    spine.TypedLowerHead headTy := by
+  simpa only using H.telescope.lowerHead
+
+/-- The joint certificate lands at the caller-specified result type shape. -/
+theorem LR.FixedHeadTelescope.outHasType
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    out.HasType outTy := by
+  exact H.telescope.outHasType
+
+/-- Add the registered-type witness to the synchronized lower endpoint
+without projecting semantic structure through a function-shape inequality. -/
+theorem LR.FixedHeadTelescope.withWitness
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy B) :
+    ∃ headElem headElemTy : TShape,
+      headElem ≤ head ∧ headElem.HasType headElemTy ∧
+        Nonempty (LE_Interp.Witness ρ headElemTy B) :=
+  (LR.FixedHeadTelescope.lowerHead H).withWitness hTy
+
+/-- The packed producer returns the synchronized lower endpoint and its
+logical application chain in one elimination.  The type bound belongs to the
+same recursive choices as the chain, so lowering `hTy` cannot be paired with
+an independently reconstructed capture telescope. -/
+theorem LR.FixedHeadTelescope.withWitnessAndChain
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    (H : LR.FixedHeadTelescope
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy B)
+    (houtNonbot : ¬out.T ≤ TShape.bot) :
+    ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        Nonempty (LE_Interp.Witness ρ headElemTy.T B) ∧
+        LR.FixedHeadShapeChain Γ₀ mcap mx my captureType
+          paths headElem headElemTy out outTy := by
+  obtain ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    hheadTy, _hheadNonbot, chain⟩ :=
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.fixedHeadShapeChain
+      H rfl rfl houtNonbot
+  exact ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hTy.mono hheadTy⟩, chain⟩
+
+/-! ### The monotone fixed-head telescope
+
+`LR.FixedHeadTelescope`'s terminal index is an *equality* index: its base
+constructor identifies the observation the ordered type peel reaches with the
+result observation the telescope is read at.  Those two are independently
+determined — the reached observation is a function of the registered type and
+the aligned capture shapes, while the result observation `outTy` is an input of
+`LR.constDefEq`, fixed by the adequacy caller before any pattern is matched and
+threaded verbatim to the leaf.  Identifying them is not merely unproved, it is
+refutable (`LR.FixedHeadTerminalRetarget.not_general`).
+
+`LR.FixedHeadTelescopeLE` replaces that equality by the single comparison
+`outTy ≤ reached` at the base.  Every consumer below is the same theorem with
+the same proof: the terminal index is read exactly twice — once for the
+caller's own `out.HasType outTy`, which the monotone base records directly, and
+once for the returned `headElemTy.T ≤ headTy` bound, which now travels through
+the comparison. -/
+
+/-- The synchronized producer certificate with a monotone terminal index. -/
+def LR.FixedHeadTelescopeLE (Γ₀ : List SExpr)
+    {p : Pattern} {mcap : p.Path → TShape}
+    (mx my captureType : p.Path → SExpr)
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out) : Prop :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE
+    (m2 := mcap)
+    (fun {n} path (elemShape typeShape : WShape n) =>
+      LRS.CaptureDefEqAligned.AtShapes (LR Γ₀)
+        (mcap path) (mx path) (my path) (captureType path)
+        elemShape typeShape)
+    head paths out headTy outTy
+
+/-- Faithfulness: an exact telescope is a monotone one at the reflexive
+comparison, so every existing producer still supplies the weakened premise. -/
+theorem LR.FixedHeadTelescope.toLE
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.toLE H
+
+/-- **THE O1 REPAIR AT THE TELESCOPE.**  Read a finished telescope at the
+caller's own result observation, given the caller's own result typing and the
+one comparison against the observation the peel reached.
+
+This is what `LR.FixedHeadTerminalRetarget` tried and could not be: the
+retarget demanded the two observations be *equal*, which is `HasType`
+functionality at the terminal head and is false.  Here they are merely
+compared, and the direction is the one every consumer needs — the head
+observation is used only as an upper bound. -/
+theorem LR.FixedHeadTelescope.retarget
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy reachedTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := reachedTy)
+      Γ₀ mx my captureType spine)
+    (htyped : out.HasType outTy) (hle : outTy ≤ reachedTy) :
+    LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCaptures.retarget H htyped hle
+
+/-- Empty monotone telescope: the caller's result typing plus the base
+comparison. -/
+theorem LR.FixedHeadTelescopeLE.nil
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr} {head headTy outTy : TShape}
+    (htyped : head.HasType outTy) (hle : outTy ≤ headTy) :
+    LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.nil (m2 := mcap) (head := head)) :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.nil htyped hle
+
+/-- Prepend one synchronized application layer to a monotone telescope.
+Verbatim `LR.FixedHeadTelescope.cons`; only the base differs. -/
+theorem LR.FixedHeadTelescopeLE.cons
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+    {m out : TShape} {path : p.Path} {paths : List p.Path}
+    (harg : a.T ≤ mcap path) (happ : m ≤ (f.app a).T)
+    (rest : LE_Interp.RHS.ShapeSpine mcap m paths out)
+    {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+    {outTy : TShape}
+    (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ₀)
+      (mcap path) (mx path) (my path) (captureType path)
+      argCap tyDom)
+    (tail : LR.FixedHeadTelescopeLE
+      (headTy := (tyFun.app argCap).T) (outTy := outTy)
+      Γ₀ mx my captureType rest) :
+    LR.FixedHeadTelescopeLE
+      (headTy := (WShape.forallE tyDom tyFun).T) (outTy := outTy)
+      Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.cons harg happ rest) := by
+  have hargCap : a ≤ argCap :=
+    WShape.LE.T_iff.1 (harg.trans capture.1)
+  exact LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.cons
+    harg happ hargCap capture.2.1 capture tail
+
+/-- The monotone certificate still lands at the caller's exact result type
+shape — that is now recorded by its base rather than derived from an index
+equality. -/
+theorem LR.FixedHeadTelescopeLE.outHasType
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    out.HasType outTy :=
+  LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.outHasType H
+
+/-- Forget the logical capture payload of a monotone telescope. -/
+theorem LR.FixedHeadTelescopeLE.lowerHead
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    spine.TypedLowerHead headTy := by
+  simpa only using
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.lowerHead H
+
+/-- Add the registered-type witness to a monotone telescope's synchronized
+lower endpoint. -/
+theorem LR.FixedHeadTelescopeLE.withWitness
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy B) :
+    ∃ headElem headElemTy : TShape,
+      headElem ≤ head ∧ headElem.HasType headElemTy ∧
+        Nonempty (LE_Interp.Witness ρ headElemTy B) :=
+  (LR.FixedHeadTelescopeLE.lowerHead H).withWitness hTy
+
+/-- The packed producer for the monotone telescope: same conclusion, same
+proof, one comparison instead of one index equality. -/
+theorem LR.FixedHeadTelescopeLE.withWitnessAndChain
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    (H : LR.FixedHeadTelescopeLE
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy B)
+    (houtNonbot : ¬out.T ≤ TShape.bot) :
+    ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        Nonempty (LE_Interp.Witness ρ headElemTy.T B) ∧
+        LR.FixedHeadShapeChain Γ₀ mcap mx my captureType
+          paths headElem headElemTy out outTy := by
+  obtain ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    hheadTy, _hheadNonbot, chain⟩ :=
+    LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE.fixedHeadShapeChain
+      H rfl rfl houtNonbot
+  exact ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hTy.mono hheadTy⟩, chain⟩
+
+/-- Everything the fixed-head application consumer needs after the ordered
+producer has finished.
+
+The lower term/type pair is shared literally by self-adequacy and the
+logical application chain.  The registered-type witness is retained at that
+exact type observation, so the consumer never projects typing backwards
+through a function-shape inequality or reselects an existential capture. -/
+def LR.FixedHeadApplication (Γ₀ : List SExpr)
+    {rho root X} (hX : LE_Interp.Witness rho root X) (depth : Nat)
+    {p : Pattern} (mcap : p.Path → TShape)
+    (mx my captureType : p.Path → SExpr)
+    (paths : List p.Path) (headType resultType : SExpr)
+    (head : TShape) {outLevel : Nat}
+    (out outTy : WShape outLevel) : Prop :=
+  ∃ (headLevel : Nat) (headElem headElemTy : WShape headLevel),
+    headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+      Nonempty (LE_Interp.Witness rho headElemTy.T headType) ∧
+      (LR Γ₀).DefEq X X headType headElem headElemTy ∧
+      LR.FixedHeadExposedChain Γ₀ mcap mx my captureType
+        paths headType resultType headElem headElemTy out outTy
+
+/-- Use heterogeneous depth-bounded adequacy to validate a closed fixed
+head at its registered displayed type.
+
+Heterogeneous `AdequacyAtDepth` supplies the term relation directly, so no
+raw type-uniqueness theorem or cast is needed for that half.  The exact
+registered-type stratification separately supplies its `isType` derivation;
+adequacy at the preceding type rung then validates the same lower type
+observation.  Closedness removes the surrounding substitution after both
+relations have been produced. -/
+theorem LR.AdequacyAtDepth.closedHeadSelf
+    (adequacy : LR.AdequacyAtDepth Γ₀ depth)
+    (hstrong : IsDefEqStrong Δ X X headType)
+    (hstrat : HasTypeStratifiedS Δ X headType core depth)
+    (W : LR.SubstWF Γ₀ σ σ' Δ rho)
+    (hXClosed : X.ClosedN) (hTypeClosed : headType.ClosedN)
+    {n : Nat} {headElem headElemTy : WShape n}
+    (hX : LE_Interp.Witness rho headElem.T X)
+    (hTy : LE_Interp.Witness rho headElemTy.T headType)
+    (htyped : headElem.HasType headElemTy) :
+    (LR Γ₀).DefEq X X headType headElem headElemTy ∧
+      (LR Γ₀).TyDefEq headType headType headElemTy := by
+  have hrel :=
+    ((adequacy hstrong hstrat hX.toInterp hTy.toInterp htyped).1 W).1
+  rw [hXClosed.subst_eq .zero, hXClosed.subst_eq .zero,
+    hTypeClosed.subst_eq .zero] at hrel
+  obtain ⟨u, hTypeStrat⟩ := hstrat.isType
+  have hTypeStrong : IsDefEqStrong Δ
+      headType headType (.sort u) := hTypeStrat.strong
+  obtain ⟨n', typeElem, sortElem, le_n, le_type,
+      hTypeInterp, hSortInterp, hTypeTyped⟩ :=
+    (LE_Interp.sound hTypeStrong W.left.fits).2 hTy.toInterp |>.out
+  have hTypeAdequate :=
+    (adequacy hTypeStrong (hTypeStrat.mono (Nat.sub_le depth 1))
+      hTypeInterp hSortInterp hTypeTyped).2 W.left
+  simp only [SExpr.subst] at hTypeAdequate
+  rw [hTypeClosed.subst_eq .zero] at hTypeAdequate
+  exact ⟨hrel, LR.toValTy le_n le_type htyped.isType
+    hSortInterp hTypeTyped hTypeAdequate⟩
+
+/-- Depth-bounded adequacy is contravariant in its depth index: a rung that
+accepts every certificate of depth `depth` accepts every smaller one after
+`HasTypeStratifiedS.mono`.  Larger index means strictly more admissible
+inputs, hence a strictly stronger package. -/
+theorem LR.AdequacyAtDepth.of_le {d depth : Nat} (hle : d ≤ depth)
+    (adequacy : LR.AdequacyAtDepth Γ₀ depth) :
+    LR.AdequacyAtDepth Γ₀ d := by
+  intro n Γ ρ M N A B core m a H hstrat hM hA hmem
+  exact adequacy H (hstrat.mono hle) hM hA hmem
+
+/-- THE TYPE-RUNG RESIDUAL of the fixed-head application fold.
+
+`LR.AdequacyAtDepth.closedHeadSelf` returns two components and consumes the
+one `adequacy` hypothesis twice.  The two calls are *not* at the same rung:
+
+* the term call has subject `X` and certificate `hstrat` at `depth` — that
+  instance is literally an instance of `LR.SelfAdequateAt Γ₀ hX depth`, which
+  the coherent algebra already holds at the same witness and depth;
+* the type call has subject `headType` and certificate `hstrat.isType`, whose
+  index is `depth - 1` (`HasTypeStratifiedS.isType`).  `closedHeadSelf` raises
+  it back with `mono` only so that a single hypothesis can serve both calls.
+
+This Prop isolates the second call.  Its depth index is the rung's, but the
+adequacy it consumes is at `depth - 1`; see `of_predecessorAdequacy`, which
+is a strict predecessor exactly when `0 < depth` (`of_lowerAdequacy`).
+Nothing here is manufactured inside the induction: the demand is an interface
+hypothesis of `LR.CoherentFixedHeadStep.of_steps`. -/
+def LR.FixedHeadTypeValidStep (Γ₀ : List SExpr) (depth : Nat) : Prop :=
+  ∀ {Δ : List SExpr} {ρ : Valuation} {σ σ' : Subst}
+      {X headType : SExpr} {core : Bool}
+      {n : Nat} {headElem headElemTy : WShape n},
+    LR.SubstWF Γ₀ σ σ' Δ ρ →
+    HasTypeStratifiedS Δ X headType core depth →
+    headType.ClosedN →
+    headElem.HasType headElemTy →
+    LE_Interp.Witness ρ headElemTy.T headType →
+    (LR Γ₀).TyDefEq headType headType headElemTy
+
+/-- The type rung is discharged by adequacy at `depth - 1`, with no `mono`
+anywhere: `HasTypeStratifiedS.isType` already lands there.  This is the exact
+depth arithmetic of the fixed-head application fold. -/
+theorem LR.FixedHeadTypeValidStep.of_predecessorAdequacy
+    (adequacy : LR.AdequacyAtDepth Γ₀ (depth - 1)) :
+    LR.FixedHeadTypeValidStep Γ₀ depth := by
+  intro Δ ρ σ σ' X headType core n headElem headElemTy W hstrat
+    hTypeClosed htyped hTy
+  obtain ⟨u, hTypeStrat⟩ := hstrat.isType
+  have hTypeStrong : IsDefEqStrong Δ headType headType (.sort u) :=
+    hTypeStrat.strong
+  obtain ⟨n', typeElem, sortElem, le_n, le_type,
+      hTypeInterp, hSortInterp, hTypeTyped⟩ :=
+    (LE_Interp.sound hTypeStrong W.left.fits).2 hTy.toInterp |>.out
+  have hTypeAdequate :=
+    (adequacy hTypeStrong hTypeStrat hTypeInterp hSortInterp hTypeTyped).2
+      W.left
+  simp only [SExpr.subst] at hTypeAdequate
+  rw [hTypeClosed.subst_eq .zero] at hTypeAdequate
+  exact LR.toValTy le_n le_type htyped.isType
+    hSortInterp hTypeTyped hTypeAdequate
+
+/-- Faithfulness: the same-rung package `closedHeadSelf` used to demand still
+discharges the isolated type rung. -/
+theorem LR.FixedHeadTypeValidStep.of_adequacyAtDepth
+    (adequacy : LR.AdequacyAtDepth Γ₀ depth) :
+    LR.FixedHeadTypeValidStep Γ₀ depth :=
+  LR.FixedHeadTypeValidStep.of_predecessorAdequacy
+    (adequacy.of_le (Nat.sub_le depth 1))
+
+/-- The strict-predecessor form, stated so the decrease is visible.  At
+`depth = 0` truncated subtraction collapses `depth - 1` onto the rung itself,
+so this producer deliberately requires `0 < depth`: the depth-zero rung is
+where the demand stops being a predecessor demand. -/
+theorem LR.FixedHeadTypeValidStep.of_lowerAdequacy
+    (hΓ₀ : Ctx.WF Γ₀) {depth : Nat} (hdepth : 0 < depth)
+    (lower : ∀ d, d < depth → LR.ContextualAdequacyAtDepth d) :
+    LR.FixedHeadTypeValidStep Γ₀ depth :=
+  LR.FixedHeadTypeValidStep.of_predecessorAdequacy
+    (lower (depth - 1) (Nat.sub_lt hdepth Nat.one_pos) hΓ₀)
+
+/-- The conversion transport consumed while zipping the fixed-head
+application chain, named rather than left as an anonymous callback.
+
+It is *not* an instance of `LR.TyDefEq.of_defeq_of_stratifiedInversion`: that
+lemma also demands the right endpoint's own validity `(LR Γ₀).TyDefEq B B a`,
+which the chain zip has no producer for.  Recorded as a separate obligation
+because `LR.FixedHeadTelescope.toApplicationWith` has always required it and
+`LR.FixedHeadShapeChain.pathSemantics` fixes its shape.
+
+**What it unfolds to** (corrected 2026-08-15 from
+`plans/probes/probeW-disjointness.lean`; the previous account, on
+`LR.FixedHeadConvertRightValid` below, was wrong in both directions).  The
+conclusion is `TyDefEq A B a`, not `TyDefEq B B a`, so at `a = .sort r` the
+step additionally demands that `A` and `B` reach the **same** sort.  Unfolded,
+that is discharged from exactly three inputs — none of them `LRS.TypeWHNFEx`:
+transport (`LRS.SortHeadNorm`, SLR), subject reduction (`LRS.SubjectRedS`, a
+CR-ladder item), and sort injectivity (`LRS.SortInv`).  See
+`LR.fixedHeadConvertStep_sort_of_parts` below.
+
+**G4 (rung-0 consumption).**  This Prop is depth-free, so it has to hold at
+rung `0` too — and there its sort observation would consume a `LRS.SortInv`
+that is itself produced at rung `0`
+(`LRS.SortInv.of_adequacyAtDepth_zero`).  That is a same-rung consumption at
+exactly that rung, and it is not papered over: `LR.FixedHeadConvertStepAt`
+below is the depth-indexed variant, modelled on `LR.SelfAdequateDefeqStepAt`,
+which is vacuous at rung `0` (`LR.FixedHeadConvertStepAt.zero`) and at every
+positive rung takes its `LRS.SortInv` from the *strictly lower* family
+(`LR.fixedHeadConvertStepAt_sort_of_lowerAdequacy`).  The consumers still
+demand the depth-free form; migrating them is a separate step, because the
+`conv`/`ret` edges of `SExpr.PathSpineWF` carry no certificate to index on. -/
+def LR.FixedHeadConvertStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {n : Nat} {A B : SExpr} {u : SLevel} {a : WShape n},
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀).TyDefEq A A a →
+    (LR Γ₀).TyDefEq A B a
+
+/-- THE ONE MISSING INPUT of `LR.FixedHeadConvertStep`: a raw type conversion
+transports validity to its right endpoint at the *same* observation.
+
+Naming it is what makes the recorded dead end usable.
+`LR.TyDefEq.of_defeq_of_stratifiedInversion` (ADQ:1168) was rejected because
+it additionally demands `(LR Γ₀).TyDefEq B B a`; that demand is exactly this
+Prop, so the convert step is one line away from it (`of_rightValid` below)
+rather than out of reach.
+
+It is not leaf-local, and the reason is visible by unfolding the goal at each
+observation.
+
+**Corrected 2026-08-15** (`plans/probes/probeW-disjointness.lean`, Part 5).
+The previous account here claimed the residual is `PiHeadNorm` =
+`TypeWHNFEx` + `PiHeadStable`.  That is wrong in *both* directions, and
+`LRS.TypeWHNFEx` never arises at all: this Prop carries `TyDefEq A A a` as a
+**hypothesis**, so the left endpoint's weak-head normal form is *given*, not
+manufactured.  What the two observations really are:
+
+* At `a = .sort r`, `LogRel.sort_iff_ty` makes the obligation *exactly* the
+  sort analogue of `LRS.PiHeadNorm`, namely `LRS.SortHeadNorm` (SLR) — a pure
+  transport, nothing existential.  Machine-checked in **both** directions:
+  `LR.fixedHeadConvertRightValid_sort_of_transport` (transport ⟹ obligation)
+  and `LRS.SortHeadNorm.of_fixedHeadConvertRightValid` (obligation ⟹
+  transport).  So nothing weaker suffices and nothing stronger is demanded.
+* At `a = .forallE b f`, `LRS.TyDefEq.forallE_iff` unfolds the goal to
+  `LRS.ValTyPi2` (`LR.tyDefEq_forallE_unfold`, SLR), whose first two conjuncts
+  are the two weak-head reductions — that half *is* `LRS.PiHeadNorm`, and the
+  CR ladder covers it — but whose remaining four conjuncts
+  (`TypeDefEqPath` ×2, `TyDefEq B₁ B₂ b`, `LRS.PiDefEq`) are *semantic
+  component* data the CR ladder does not produce.  That half is isolated as
+  `LR.PiComponentTransport` (SLR); see
+  `LR.fixedHeadConvertRightValid_forallE_of_parts`.
+
+So the CR route covers the head-shape half at both observations and does not
+cover the component half at the Pi observation.  Nothing weaker is available at
+the consumer either: `SExpr.PathSpineWF`'s `conv`/`ret` edges carry a bare
+`IsDefEq` and no shape, witness, or endpoint validity at all — the G5 gap in
+its exact position. -/
+def LR.FixedHeadConvertRightValid (Γ₀ : List SExpr) : Prop :=
+  ∀ {n : Nat} {A B : SExpr} {u : SLevel} {a : WShape n},
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀).TyDefEq A A a →
+    (LR Γ₀).TyDefEq B B a
+
+/-- The convert step from the right-endpoint residual.  Recorded so the
+inventory names the honest obligation: `FixedHeadConvertStep` is not an extra
+gap beside the inversion package, it is that package plus validity transport.
+
+**Read the price honestly** (corrected 2026-08-15).  The docstring on
+`LR.FixedHeadConvertRightValid` above used to say the convert step is "one
+line away" from `LR.TyDefEq.of_defeq_of_stratifiedInversion`.  The *line* is
+one line; the *input* is not.  `inv` here is the full, uncollapsed
+`JointStratifiedInversion`: its `sortInv` field is unbounded-depth sort
+injectivity, and its `forallEInv` field is `IsDefEq`-valued — i.e. already
+collapsed — Pi inversion with endpoint stratification bookkeeping at `n - 1`,
+which is strictly stronger than the path-valued `LRS.PiPathInv` the rest of
+the development charges.  So this route buys the convert step at the price of
+the whole inversion package, path collapse included.  The per-observation
+theorems below buy the same observations at CR-ladder prices instead. -/
+theorem LR.FixedHeadConvertStep.of_rightValid
+    (inv : JointStratifiedInversion) (hΓ₀ : Ctx.WF Γ₀)
+    (right : LR.FixedHeadConvertRightValid Γ₀) :
+    LR.FixedHeadConvertStep Γ₀ := by
+  intro n A B u a hEq hAA
+  exact LR.TyDefEq.of_defeq_of_stratifiedInversion inv hΓ₀ hEq hAA
+    (right hEq hAA)
+
+/-! #### The two observations, at CR-ladder prices
+
+Ported from `plans/probes/probeW-disjointness.lean` Part 5.  The generic
+unfoldings (`LR.tyDefEq_sort_self_iff`, `LR.tyDefEq_sort_iff`,
+`LR.tyDefEq_forallE_unfold`) and the two named residuals (`LRS.SortHeadNorm`,
+`LR.PiComponentTransport`) live in `ShapeLogRel.lean`; what is here is what
+names the ADQ obligations. -/
+
+omit [Params.Semantic] in
+/-- **The caveat, half one.**  The sort observation of
+`LR.FixedHeadConvertRightValid` follows from a pure *transport*. -/
+theorem LR.fixedHeadConvertRightValid_sort_of_transport {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (norm : LRS.SortHeadNorm) {n : Nat} {A B : SExpr}
+    {u : SLevel} {r : Bool}
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A (.sort r)) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq B B (.sort r) := by
+  obtain ⟨w, hred⟩ := LR.tyDefEq_sort_self_iff.1 hAA
+  obtain ⟨w', hred'⟩ := norm hΓ₀ hEq hred
+  exact LR.tyDefEq_sort_self_iff.2 ⟨w', hred'⟩
+
+omit [Params.Semantic] in
+/-- **The caveat, half two.**  Conversely, the sort observation of
+`LR.FixedHeadConvertRightValid` *is* that transport: nothing weaker suffices,
+and nothing stronger is demanded.  In particular `LRS.TypeWHNFEx` is neither
+needed nor implied. -/
+theorem LRS.SortHeadNorm.of_fixedHeadConvertRightValid
+    (right : ∀ Γ₀ : List SExpr, LR.FixedHeadConvertRightValid Γ₀) :
+    LRS.SortHeadNorm := by
+  intro Γ X Y w s _ hEq hred
+  have hXX : (LR Γ : LogRel Γ 0).TyDefEq X X (WShape.sort true) :=
+    LR.tyDefEq_sort_self_iff.2 ⟨w, hred⟩
+  exact LR.tyDefEq_sort_self_iff.1 (right Γ hEq hXX)
+
+omit [Params.Semantic] in
+/-- **The Pi observation, split.**  `LRS.PiHeadNorm` supplies the head-shape
+half, which the CR ladder covers; `LR.PiComponentTransport` supplies the rest,
+which it does not. -/
+theorem LR.fixedHeadConvertRightValid_forallE_of_parts {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (norm : LRS.PiHeadNorm) (comp : LR.PiComponentTransport Γ₀)
+    {n : Nat} {A B : SExpr} {u : SLevel} {b : WShape n} {f : WShapeFun n}
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq A A (.forallE b f)) :
+    (LR Γ₀ : LogRel Γ₀ (n+1)).TyDefEq B B (.forallE b f) := by
+  obtain ⟨B₁, F₁, _, _, _, _, hred, _, _, _, _, _⟩ :=
+    LR.tyDefEq_forallE_unfold.1 hAA
+  obtain ⟨B₂, F₂, hredB⟩ := norm hΓ₀ hEq hred
+  obtain ⟨u', v', hdom, hcod, hty, hpi⟩ := comp hEq hAA hredB hredB
+  exact LR.tyDefEq_forallE_unfold.2
+    ⟨B₂, F₂, B₂, F₂, u', v', hredB, hredB, hdom, hcod, hty, hpi⟩
+
+omit [Params.Semantic] in
+/-- **The step itself, not just its right-endpoint residual.**
+`LR.FixedHeadConvertStep` concludes `TyDefEq A B a`, so its sort case
+additionally demands that `A` and `B` reach the *same* sort.  Discharged from
+three inputs, none of which is `LRS.TypeWHNFEx`: transport
+(`LRS.SortHeadNorm`), subject reduction (`LRS.SubjectRedS`, a CR-ladder item),
+and sort injectivity (`LRS.SortInv`, the depth-0 item). -/
+theorem LR.fixedHeadConvertStep_sort_of_parts {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (norm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) {n : Nat} {A B : SExpr} {u : SLevel} {r : Bool}
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A (.sort r)) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B (.sort r) := by
+  obtain ⟨w, hredA⟩ := LR.tyDefEq_sort_self_iff.1 hAA
+  obtain ⟨w', hredB⟩ := norm hΓ₀ hEq hredA
+  have hA' : IsDefEq Γ₀ A (.sort w) (.sort u) := sr hΓ₀ hredA hEq.hasType.1
+  have hB' : IsDefEq Γ₀ B (.sort w') (.sort u) := sr hΓ₀ hredB hEq.hasType.2
+  cases sinv hΓ₀ (hA'.symm.trans (hEq.trans hB'))
+  exact LR.tyDefEq_sort_iff.2 ⟨w, hredA, hredB⟩
+
+/-! #### The convert step, discharged (2026-08-15)
+
+The account above stops at "the CR route covers the head-shape half at both
+observations and does not cover the component half at the Pi observation".
+That is a correct reading of *one* unfolding, and a wrong reading of the
+obligation.  `plans/probes/probeR12-picomponent.lean` and `LR.convertStepAt_all`
+(SLR) show why: **the component half at the Pi observation is the same
+statement one shape level down**, so `LR.FixedHeadConvertStep` is not a
+fixed set of residuals but an induction on the shape level, and
+`LR.PiComponentTransport` is its inductive step rather than a new input.
+
+The two theorems below are the consequence, stated against the ADQ `Prop`s.
+The induction is on the *shape level*, which is orthogonal to the adequacy
+rung, so the G4 note in the next subsection is untouched: `LRS.SortInv` is
+still consumed at the sort observation at every level, exactly as before, and
+`LR.FixedHeadConvertStepAt` remains the right mitigation. -/
+
+/-- **HEADLINE.**  `LR.FixedHeadConvertStep` — recorded above as "THE ONE
+MISSING INPUT" — from the CR ladder, `LRS.SortInv` (adequacy rung `0`) and one
+new head-form transport.
+
+Of the six inputs, four are CR-ladder rungs (`LRS.SubjectRedS`,
+`LRS.SortHeadNorm`, `LRS.PiHeadNorm`, `LRS.PiEdgeInv`), one is the depth-0
+adequacy item `LRS.SortInv` that the sort observation already charged, and one
+is new: `LRS.IndTyHeadNorm`, the `indTy` analogue of the other two head-form
+transports.  Nothing here is `LRS.TypeWHNFEx`, path collapse, or
+`JointStratifiedInversion`; in particular this route does *not* pay the price
+that `LR.FixedHeadConvertStep.of_rightValid` pays.
+
+**What the ladder rungs cost** (2026-08-15).  `LRS.PiEdgeInv` and
+`LRS.PiHeadNorm` are inside the loop recorded on
+`LRS.crComplete_is_the_last_input` (SLR) — they are interderivable with
+`LRS.PiPathInv`, the 16C′ leaf.  So the correct reading of this theorem is not
+"the convert step is now free" but the sharper and still valuable one: **the
+convert step demands nothing beyond the leaf itself**, plus `LRS.SortInv` at
+rung `0` and one genuinely new head-form transport.  It was recorded as a
+separate, unrelated obligation; it is not one. -/
+theorem LR.FixedHeadConvertStep.of_crLadder {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (snorm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) (norm : LRS.PiHeadNorm) (inv : LRS.PiEdgeInv)
+    (ind : LRS.IndTyHeadNorm) : LR.FixedHeadConvertStep Γ₀ :=
+  fun {n} => LR.convertStepAt_all hΓ₀ sr snorm sinv norm inv ind n
+
+/-- And hence the right-endpoint residual, by `symm_ty ∘ left_ty`. -/
+theorem LR.FixedHeadConvertRightValid.of_crLadder {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (snorm : LRS.SortHeadNorm)
+    (sinv : LRS.SortInv) (norm : LRS.PiHeadNorm) (inv : LRS.PiEdgeInv)
+    (ind : LRS.IndTyHeadNorm) : LR.FixedHeadConvertRightValid Γ₀ :=
+  fun hEq hAA => (LR Γ₀).left_ty ((LR Γ₀).symm_ty
+    (LR.FixedHeadConvertStep.of_crLadder hΓ₀ sr snorm sinv norm inv ind hEq hAA))
+
+/-- The same with `LRS.PiEdgeInv` discharged by rung R11
+(`LRS.PiEdgeInv.of_crLadder_noAdequacy`, SLR) and `LRS.PiHeadNorm` by
+`LRS.PiHeadNorm.of_crLadder_noAdequacy`, so that only rungs with no producer
+remain visible.  Four inputs: three CR-ladder rungs, `LRS.SortInv` at adequacy
+rung `0`, and the one new head-form transport. -/
+theorem LR.FixedHeadConvertStep.of_crLadder_R11 {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete)
+    (std : LRS.PiStandard) (snorm : LRS.SortHeadNorm) (sinv : LRS.SortInv)
+    (ind : LRS.IndTyHeadNorm) : LR.FixedHeadConvertStep Γ₀ :=
+  have sr : LRS.SubjectRedS := LRS.SubjectRedS.of_parRedSDefeq srp
+  LR.FixedHeadConvertStep.of_crLadder hΓ₀ sr snorm sinv
+    (LRS.PiHeadNorm.of_crLadder_noAdequacy sr cr std)
+    (LRS.PiEdgeInv.of_crLadder_noAdequacy srp cr) ind
+
+/-! #### G4: the depth-indexed convert step
+
+`LR.FixedHeadConvertStep` is depth-free, so it must hold at rung `0`, and its
+sort observation there would consume a `LRS.SortInv` produced at rung `0` —
+same-rung, at exactly that rung.  The mitigation is the one
+`LR.SelfAdequateDefeqStepAt` already uses: index the Prop by the rung, and gate
+it on a stratification certificate for the left endpoint at a *strictly*
+smaller depth.  The index has one job, and the arithmetic makes it explicit:
+`depth < outerDepth` forces `0 < outerDepth`, which is exactly what puts rung
+`0` inside the strictly-lower family.
+
+Landed **beside** the depth-free Prop rather than replacing it.  Migrating the
+consumers is not a one-step change: `convert` is spent inside
+`LR.FixedHeadShapeChain.pathSemantics` while zipping a `SExpr.PathSpineWF`,
+whose `conv`/`ret` edges carry a bare `IsDefEq` and no stratification
+certificate to index on.  Supplying one there is the G5 gap, not this one. -/
+
+/-- Depth-indexed `LR.FixedHeadConvertStep`, shaped like
+`LR.SelfAdequateDefeqStepAt`: the left endpoint arrives with a stratification
+certificate strictly below the rung. -/
+def LR.FixedHeadConvertStepAt (Γ₀ : List SExpr) (outerDepth : Nat) : Prop :=
+  ∀ {n : Nat} {A B : SExpr} {u : SLevel} {a : WShape n}
+      {core : Bool} {depth : Nat},
+    depth < outerDepth →
+    HasTypeStratifiedS Γ₀ A (.sort u) core depth →
+    IsDefEq Γ₀ A B (.sort u) →
+    (LR Γ₀).TyDefEq A A a →
+    (LR Γ₀).TyDefEq A B a
+
+omit [Params.Semantic] in
+/-- The indexed form is a weakening of the depth-free one, so demanding it can
+never demand more than the current interface does. -/
+theorem LR.FixedHeadConvertStep.at (h : LR.FixedHeadConvertStep Γ₀)
+    (outerDepth : Nat) : LR.FixedHeadConvertStepAt Γ₀ outerDepth :=
+  fun _ _ hEq hAA => h hEq hAA
+
+omit [Params.Semantic] in
+/-- **The G4 mitigation, stated.**  At rung `0` the indexed step is
+unconditional, so the rung that *produces* `LRS.SortInv` consumes nothing from
+itself.  The same-rung consumption exists only for the depth-free Prop. -/
+theorem LR.FixedHeadConvertStepAt.zero :
+    LR.FixedHeadConvertStepAt Γ₀ 0 :=
+  fun hdepth _ _ _ => absurd hdepth (Nat.not_lt_zero _)
+
+/-- **The G4 mitigation, discharged at every positive rung.**  The sort
+observation of the indexed step takes its `LRS.SortInv` from the strictly
+lower adequacy family, because the certificate's `depth < outerDepth` already
+forces `0 < outerDepth` and `LRS.SortInv` is produced at rung `0`.  Nothing is
+consumed at the rung being built. -/
+theorem LR.fixedHeadConvertStepAt_sort_of_lowerAdequacy {Γ₀ : List SExpr}
+    (hΓ₀ : Ctx.WF Γ₀) (sr : LRS.SubjectRedS) (norm : LRS.SortHeadNorm)
+    {outerDepth : Nat}
+    (lower : ∀ d, d < outerDepth → LR.ContextualAdequacyAtDepth d)
+    {n : Nat} {A B : SExpr} {u : SLevel} {r : Bool}
+    {core : Bool} {depth : Nat}
+    (hdepth : depth < outerDepth)
+    (_hstrat : HasTypeStratifiedS Γ₀ A (.sort u) core depth)
+    (hEq : IsDefEq Γ₀ A B (.sort u))
+    (hAA : (LR Γ₀ : LogRel Γ₀ n).TyDefEq A A (.sort r)) :
+    (LR Γ₀ : LogRel Γ₀ n).TyDefEq A B (.sort r) :=
+  LR.fixedHeadConvertStep_sort_of_parts hΓ₀ sr norm
+    (LRS.SortInv.of_lowerAdequacy
+      (Nat.lt_of_le_of_lt (Nat.zero_le depth) hdepth) lower) hEq hAA
+
+/-! ##### Vacuity check for `LR.FixedHeadConvertStepAt`
+
+Standing policy: every new `Prop` exhibits an inhabitant or an attempted
+derivation of `False`.  `LR.FixedHeadConvertStepAt Γ₀ 0` is inhabited
+vacuously (`.zero`), and that alone would be a weak certificate, so the lemma
+below checks a *positive* rung: at `outerDepth = 1` every hypothesis of the
+Prop is simultaneously satisfiable **and** the conclusion holds there.  So the
+Prop is neither empty-hypothesis vacuous nor refutable at the one instance
+that can be computed outright.  No derivation of `False` was found; the Prop is
+also implied by the depth-free one (`LR.FixedHeadConvertStep.at`), which
+`LR.FixedHeadConvertStep.of_rightValid` already produces from
+`JointStratifiedInversion`. -/
+
+omit [Params.Semantic] in
+/-- Non-vacuity at a positive rung: the five components below are, in order,
+the depth gate, the stratification certificate, the type equality, the left
+validity — i.e. all four hypotheses of `LR.FixedHeadConvertStepAt Γ₀ 1` — and
+then its conclusion, all met at once by a syntactic sort. -/
+theorem LR.fixedHeadConvertStepAt_nonvacuous {Γ₀ : List SExpr} {w : SLevel}
+    {r : Bool} :
+    (0 : Nat) < 1 ∧
+      HasTypeStratifiedS Γ₀ (.sort w) (.sort w.succ) true 0 ∧
+      IsDefEq Γ₀ (.sort w) (.sort w) (.sort w.succ) ∧
+      (LR Γ₀ : LogRel Γ₀ 0).TyDefEq (.sort w) (.sort w) (WShape.sort r) ∧
+      (LR Γ₀ : LogRel Γ₀ 0).TyDefEq (.sort w) (.sort w) (WShape.sort r) :=
+  ⟨Nat.one_pos, HasTypeStratifiedS.sort_zero, .sort,
+    LR.tyDefEq_sort_self_iff.2 ⟨w, .rfl⟩,
+    LR.tyDefEq_sort_self_iff.2 ⟨w, .rfl⟩⟩
+
+/-- Finish a fixed-head application package from one packed telescope and
+the semantic type equalities justified at the caller's derivation-aware
+boundary.
+
+`headSelf` is invoked only for the literal lower head/type/witness triple
+returned by `withWitnessAndChain`.  Likewise, `convert` is used only while
+zipping the supplied `PathSpineWF`; it is never promoted to an ambient
+conversion oracle.  This keeps the proof-relevant endpoint choice inside
+one elimination while leaving the well-founded source of the type
+equalities explicit in the producer's signature. -/
+theorem LR.FixedHeadTelescope.toApplicationWith
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    {headType resultType : SExpr}
+    {hX : LE_Interp.Witness rho root X} {depth : Nat}
+    (H : LR.FixedHeadTelescope
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness rho headTy headType)
+    (houtNonbot : ¬out.T ≤ TShape.bot)
+    (raw : SExpr.PathSpineWF Γ₀ mx captureType
+      headType paths resultType)
+    (resultRel : (LR Γ₀).TyDefEq
+      resultType resultType outTy)
+    (convert : ∀ {n : Nat} {A B : SExpr} {u : SLevel}
+        {a : WShape n},
+      IsDefEq Γ₀ A B (.sort u) →
+      (LR Γ₀).TyDefEq A A a →
+      (LR Γ₀).TyDefEq A B a)
+    (headSelf : ∀ {headLevel : Nat}
+        {headElem headElemTy : WShape headLevel},
+      headElem.T ≤ head →
+      headElem.HasType headElemTy →
+      LE_Interp.Witness rho headElemTy.T headType →
+      (LR Γ₀).DefEq X X headType headElem headElemTy ∧
+        (LR Γ₀).TyDefEq headType headType headElemTy) :
+    LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy := by
+  obtain ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hheadTy⟩, chain⟩ :=
+    H.withWitnessAndChain hTy houtNonbot
+  have ⟨hheadTermRel, hheadRel⟩ :=
+    headSelf hhead htyped hheadTy
+  have semantics : LR.FixedHeadPathSemantics Γ₀
+      mcap mx my captureType chain raw :=
+    chain.pathSemantics raw hheadRel resultRel convert
+  exact ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hheadTy⟩, hheadTermRel, semantics.exposed⟩
+
+/-- The same fold for the monotone telescope.  Every input is unchanged,
+including `resultRel` — the caller's `hA`, at the caller's own `outTy`, which
+is where the terminal observation was always going to have to be reconciled. -/
+theorem LR.FixedHeadTelescopeLE.toApplicationWith
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    {headType resultType : SExpr}
+    {hX : LE_Interp.Witness rho root X} {depth : Nat}
+    (H : LR.FixedHeadTelescopeLE
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness rho headTy headType)
+    (houtNonbot : ¬out.T ≤ TShape.bot)
+    (raw : SExpr.PathSpineWF Γ₀ mx captureType
+      headType paths resultType)
+    (resultRel : (LR Γ₀).TyDefEq
+      resultType resultType outTy)
+    (convert : ∀ {n : Nat} {A B : SExpr} {u : SLevel}
+        {a : WShape n},
+      IsDefEq Γ₀ A B (.sort u) →
+      (LR Γ₀).TyDefEq A A a →
+      (LR Γ₀).TyDefEq A B a)
+    (headSelf : ∀ {headLevel : Nat}
+        {headElem headElemTy : WShape headLevel},
+      headElem.T ≤ head →
+      headElem.HasType headElemTy →
+      LE_Interp.Witness rho headElemTy.T headType →
+      (LR Γ₀).DefEq X X headType headElem headElemTy ∧
+        (LR Γ₀).TyDefEq headType headType headElemTy) :
+    LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy := by
+  obtain ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hheadTy⟩, chain⟩ :=
+    H.withWitnessAndChain hTy houtNonbot
+  have ⟨hheadTermRel, hheadRel⟩ :=
+    headSelf hhead htyped hheadTy
+  have semantics : LR.FixedHeadPathSemantics Γ₀
+      mcap mx my captureType chain raw :=
+    chain.pathSemantics raw hheadRel resultRel convert
+  exact ⟨headLevel, headElem, headElemTy, hhead, htyped,
+    ⟨hheadTy⟩, hheadTermRel, semantics.exposed⟩
+
+/-- Finish the packed fixed-head application using the exact registered-head
+typing at one strictly earlier adequacy rung.
+
+This is the conversion-safe producer adapter.  Heterogeneous
+`AdequacyAtDepth` validates the exact lower head selected by the packed
+telescope without a raw type cast; the registered derivation validates that
+same lower type observation.  Both relations are retained in
+`FixedHeadApplication`. -/
+theorem LR.FixedHeadTelescope.toApplicationWithAdequacyAtDepth
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    {headType resultType : SExpr}
+    {hX : LE_Interp.Witness rho root X} {depth : Nat}
+    (H : LR.FixedHeadTelescope
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness rho headTy headType)
+    (houtNonbot : ¬out.T ≤ TShape.bot)
+    (raw : SExpr.PathSpineWF Γ₀ mx captureType
+      headType paths resultType)
+    (resultRel : (LR Γ₀).TyDefEq
+      resultType resultType outTy)
+    (convert : ∀ {n : Nat} {A B : SExpr} {u : SLevel}
+        {a : WShape n},
+      IsDefEq Γ₀ A B (.sort u) →
+      (LR Γ₀).TyDefEq A A a →
+      (LR Γ₀).TyDefEq A B a)
+    (adequacy : LR.AdequacyAtDepth Γ₀ depth)
+    (hhead : head ≤ root)
+    (hstrong : IsDefEqStrong Δ X X headType)
+    (hstrat : HasTypeStratifiedS Δ X headType core depth)
+    (W : LR.SubstWF Γ₀ σ σ' Δ rho)
+    (hXClosed : X.ClosedN) (hTypeClosed : headType.ClosedN) :
+    LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy := by
+  apply H.toApplicationWith hTy houtNonbot raw resultRel convert
+  intro headLevel headElem headElemTy helem htyped hheadTy
+  exact adequacy.closedHeadSelf hstrong hstrat W hXClosed hTypeClosed
+    (hX.mono (helem.trans hhead)) hheadTy htyped
+
+/-- The proof-independent result required from one exact fixed RHS head.
+It consumes the rule's semantic `ShapeSpine`, the two typed capture spines,
+and aligned capture relations to produce the generated RHS relation. -/
+def LR.FixedHeadResult (Γ₀ : List SExpr)
+    (hX : LE_Interp.Witness ρ root X) : Prop :=
+  ∀ {Δ : List SExpr} {σ σ' : Subst},
+    LR.SubstWF Γ₀ σ σ' Δ ρ →
+    ∀ {n : Nat}
+      {rec ctor : Name} {major arity : Nat}
+      {recLs : List SLevel}
+      {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+      {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      {rule : Pattern.IotaRule r} {out : WShape (n + 1)}
+      {head headTy : TShape}
+      {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {A : SExpr} {outTy : WShape (n + 1)},
+    X = SExpr.mkInst recLs rule.df.rhs →
+    head ≤ root →
+    IsDefEqStrong Δ X X (SExpr.mkInst recLs rule.df.type) →
+    ∀ hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+      head rule.capturePaths out.T,
+    LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType hshape →
+    LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type) →
+    SExpr.PathSpineWF Γ₀ mx captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    SExpr.PathSpineWF Γ₀ my captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+      match path with
+      | Sum.inl p => LRS.CaptureDefEqAligned (LR (n := n + 1) Γ₀) (mrec p)
+          (mx path) (my path) (captureType path)
+      | Sum.inr p => LRS.CaptureDefEqAligned (LR (n := n) Γ₀) (mctor p)
+          (mx path) (my path) (captureType path)) →
+    out.HasType outTy →
+    (LR (n := n + 1) Γ₀).TyDefEq A A outTy →
+    (LR (n := n + 1) Γ₀).DefEq
+      (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy
+
+/-- The fixed-head result at one explicit stratified typing depth.
+
+The proof-relevant semantic recursion is Nat-first: conversion may restart
+from an arbitrary witness only after the typing depth decreases.  Retaining
+the depth here prevents a same-witness producer from silently consuming the
+depth-polymorphic result it is still constructing.  The public
+`FixedHeadResult` is recovered below only after this predicate has been
+constructed at every depth. -/
+def LR.FixedHeadResultAt (Γ₀ : List SExpr)
+    (hX : LE_Interp.Witness ρ root X) (depth : Nat) : Prop :=
+  ∀ {Δ : List SExpr} {σ σ' : Subst},
+    LR.SubstWF Γ₀ σ σ' Δ ρ →
+    ∀ {n : Nat}
+      {rec ctor : Name} {major arity : Nat}
+      {recLs : List SLevel}
+      {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+      {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+      {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+        (RecursorIotaPattern rec major ctor arity).Check}
+      {rule : Pattern.IotaRule r} {out : WShape (n + 1)}
+      {head headTy : TShape}
+      {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {A : SExpr} {outTy : WShape (n + 1)},
+    X = SExpr.mkInst recLs rule.df.rhs →
+    head ≤ root →
+    IsDefEqStrong Δ X X (SExpr.mkInst recLs rule.df.type) →
+    HasTypeStratifiedS Δ X (SExpr.mkInst recLs rule.df.type) true depth →
+    ∀ hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+      head rule.capturePaths out.T,
+    LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType hshape →
+    LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type) →
+    SExpr.PathSpineWF Γ₀ mx captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    SExpr.PathSpineWF Γ₀ my captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+      match path with
+      | Sum.inl p => LRS.CaptureDefEqAligned (LR (n := n + 1) Γ₀) (mrec p)
+          (mx path) (my path) (captureType path)
+      | Sum.inr p => LRS.CaptureDefEqAligned (LR (n := n) Γ₀) (mctor p)
+          (mx path) (my path) (captureType path)) →
+    out.HasType outTy →
+    (LR (n := n + 1) Γ₀).TyDefEq A A outTy →
+    (LR (n := n + 1) Γ₀).DefEq
+      (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy
+
+/-- Forget the explicit stratification certificate when an already-complete
+fixed-head result is available. -/
+theorem LR.FixedHeadResult.at
+    (H : LR.FixedHeadResult Γ₀ hX) (depth : Nat) :
+    LR.FixedHeadResultAt Γ₀ hX depth := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong _hstrat hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  exact H W hsyntax hhead hstrong hshape htel hTyReg
+    hspineX hspineY hcap hout hA
+
+/-- Recover the proof-independent API once the Nat-first recursion has
+constructed its depth-indexed result for every stratification depth. -/
+theorem LR.FixedHeadResult.of_forall_at
+    (H : ∀ depth, LR.FixedHeadResultAt Γ₀ hX depth) :
+    LR.FixedHeadResult Γ₀ hX := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  obtain ⟨depth, hleft, _⟩ := hstrong.stratify
+  exact H depth W hsyntax hhead hstrong hleft hshape htel hTyReg
+    hspineX hspineY hcap hout hA
+
+theorem LR.FixedHeadResultAt.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.FixedHeadResultAt Γ₀ hX depth) :
+    LR.FixedHeadResultAt Γ₀ (hX.mono hle) depth := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hstrat hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  exact H W hsyntax (hhead.trans hle) hstrong hstrat hshape htel hTyReg
+    hspineX hspineY hcap hout hA
+
+theorem LR.FixedHeadResult.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.FixedHeadResult Γ₀ hX) :
+    LR.FixedHeadResult Γ₀ (hX.mono hle) := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  exact H W hsyntax (hhead.trans hle) hstrong hshape htel hTyReg
+    hspineX hspineY hcap hout hA
+
+theorem LR.FixedHeadResult.bot
+    {nroot : Nat} {X : SExpr} :
+    LR.FixedHeadResult Γ₀
+      (LE_Interp.Witness.bot (ρ := ρ) (n := nroot) (M := X)) := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  have hheadBot : head ≤ TShape.bot :=
+    hhead.trans TShape.bot_eqv.1
+  have houtBot : out.T ≤ TShape.bot := hshape.le_bot hheadBot
+  have houtEq : out = .bot := TShape.le_bot.1 houtBot
+  subst out
+  exact (LR Γ₀).bot hout.isType
+
+/-- A bound variable cannot be the closed registered fixed head of an iota
+rule.  This constructor is therefore discharged before inspecting either
+the semantic application spine or any logical capture evidence. -/
+theorem LR.FixedHeadResult.bvar
+    {ρ : Valuation} {root : TShape} {i : Nat}
+    (hle : root ≤ ρ i) :
+    LR.FixedHeadResult Γ₀ (LE_Interp.Witness.bvar hle) := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  have hclosed : (SExpr.bvar i).ClosedN 0 := by
+    rw [hsyntax]
+    exact rule.rhsClosed.mkInstS
+  simp [SExpr.ClosedN] at hclosed
+
+/-- A fixed sort head either remains a sort when the generated capture
+spine is empty or collapses to bottom at its first application.  This is the
+first constructor of the canonical fixed-head algebra; it is independent of
+semantic recursion because sorts have no ordinary or abstract children. -/
+theorem LR.FixedHeadResult.sort
+    (hroot : root ≤ TShape.sort (decide (l ≠ SLevel.zero))) :
+    LR.FixedHeadResult Γ₀
+      (LE_Interp.Witness.sort (ρ := ρ) (l := l) hroot) := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  generalize hpaths : rule.capturePaths = paths at hshape hspineX hspineY
+  cases hshape with
+  | nil =>
+    have hrhsX : r.1.applyS recLs mx = .sort l := by
+      rw [← rule.rhsApply, hpaths]
+      simpa only [List.map_nil, List.foldl_nil] using hsyntax.symm
+    have hrhsY : r.1.applyS recLs my = .sort l := by
+      rw [← rule.rhsApply, hpaths]
+      simpa only [List.map_nil, List.foldl_nil] using hsyntax.symm
+    rw [hrhsX, hrhsY]
+    have houtSortT : out.T ≤ TShape.sort (decide (l ≠ SLevel.zero)) :=
+      hhead.trans hroot
+    have houtSort : out ≤ .sort (decide (l ≠ SLevel.zero)) := by
+      simpa [TShape.sort, WShape.lift_sort] using
+        (TShape.LE.lift_r (Nat.zero_le (n + 1))).1 houtSortT
+    obtain rfl | rfl := WShape.le_sort.1 houtSort
+    · exact (LR Γ₀).bot hout.isType
+    · have houtTy : outTy = .type := by
+        ext1
+        simp only [WShape.HasType, WShape.sort] at hout
+        generalize outTy.val = outTyVal at hout
+        let .sort := Shape.HasType.unfold_iff.1 hout
+        rfl
+      subst outTy
+      exact (LR Γ₀).sort_iff.2 ⟨l, .rfl, .rfl⟩
+  | @cons n' f arg m out' path paths harg happ hrest =>
+    have hfSortT : f.T ≤ TShape.sort (decide (l ≠ SLevel.zero)) :=
+      hhead.trans hroot
+    have hfSort : f ≤ .sort (decide (l ≠ SLevel.zero)) := by
+      simpa [TShape.sort, WShape.lift_sort] using
+        (TShape.LE.lift_r (Nat.zero_le (n' + 1))).1 hfSortT
+    have hfapp : f.app arg = .bot := by
+      obtain rfl | rfl := WShape.le_sort.1 hfSort
+      · exact WShape.bot_app
+      · rfl
+    have hmBot : m ≤ TShape.bot := by
+      rw [hfapp] at happ
+      exact happ.trans TShape.bot_eqv.1
+    have houtBot : out.T ≤ TShape.bot := hrest.le_bot hmBot
+    have houtEq : out = .bot := TShape.le_bot.1 houtBot
+    subst out
+    exact (LR Γ₀).bot hout.isType
+
+/-! ### The ordered telescope producer
+
+`WShape.HasTypeLam.peelLayer` is the TERM side of the peel; the recursion
+itself is driven by the TYPE side, and the lemma that moves a registered-type
+witness across one binder in lockstep with `LR.FixedHeadTelescope.cons`'s
+codomain index is `LE_Interp.Witness.forallE_inst`.  That coincidence is the
+producer: `cons` demands its tail at `(tyFun.app argCap).T`, and
+`forallE_inst` delivers the next registered-type witness at exactly that
+observation, instantiated at the same `argCap` the capture is aligned at.
+
+Everything is continuation-passing.  No component of a layer is
+existentially re-chosen and no `Nonempty` appears, which is what keeps the
+`Type`-valued witness usable (N2 decision (ii)). -/
+
+/-- The per-layer input of the ordered peel.
+
+The equation `headTy = (WShape.forallE tyDom tyFun).T` is the capture-domain
+link proper: the registered type's observation at this layer *is* a Pi
+observation whose domain is the shape the aligned capture is indexed by, at
+the semantic layer's own level.  `B = .forallE Bdom Bbody` is carried as part
+of the layer datum rather than derived, because `PathSpineWF` reaches the
+syntactic Pi form only through `conv`/`ret` edges carrying bare `IsDefEq`
+(the G5 gap); keeping it a datum leaves that cost visible and outside the
+fold. -/
+def LR.FixedHeadOrderedLink (Γ₀ : List SExpr) (ρ : Valuation) {p : Pattern}
+    (mcap : p.Path → TShape) (mx my captureType : p.Path → SExpr) : Prop :=
+  ∀ {C : Prop} {n : Nat} (path : p.Path) (a : WShape n)
+      (headTy : TShape) (B : SExpr),
+    a.T ≤ mcap path →
+    LE_Interp.Witness ρ headTy B →
+    (∀ (tyDom : WShape n) (tyFun : WShapeFun n) (argCap : WShape n)
+        (Bdom Bbody : SExpr),
+      headTy = (WShape.forallE tyDom tyFun).T →
+      B = .forallE Bdom Bbody →
+      a ≤ argCap →
+      LRS.CaptureDefEqAligned.AtShapes (LR Γ₀) (mcap path)
+        (mx path) (my path) (captureType path) argCap tyDom →
+      LE_Interp.Witness ρ argCap.T (mx path) → C) → C
+
+/-- The terminal input of the first ordered peel: at the observation the peel
+reaches, the semantic result of the spine is typed.
+
+**REFUTED — see `LR.FixedHeadTerminalLink.not_nonbot` below.**  It quantifies
+over *every* observation carrying a witness, and `LE_Interp.Witness.bot` is a
+witness of every syntax at `TShape.bot`, so the Prop forces `out ≤ TShape.bot`.
+Every consumer of the ordered peel holds `¬out.T ≤ TShape.bot`, so no consumer
+can ever supply it.  This is the same disease as
+`LR.FixedHeadTerminalRetarget`: a terminal fact stated as a *law over
+observations* rather than as a datum at the observation actually reached.
+`LR.FixedHeadTelescopeLE.ofOrderedLink` is the repaired peel — it takes no
+terminal law at all and hands the reached observation back to its caller. -/
+def LR.FixedHeadTerminalLink (ρ : Valuation) (out : TShape) : Prop :=
+  ∀ (headTy : TShape) (B : SExpr),
+    LE_Interp.Witness ρ headTy B → out.HasType headTy
+
+/-- **`LR.FixedHeadTerminalLink` FORCES ITS SUBJECT TO BE BOTTOM.**
+`LE_Interp.Witness.bot` (SLR:3928) is a witness of an arbitrary syntax at
+`TShape.bot`, and `TShape.HasType.bot_r` (SLR:3120) turns the resulting typing
+into `out ≤ TShape.bot`. -/
+theorem LR.FixedHeadTerminalLink.le_bot {ρ : Valuation} {out : TShape}
+    (H : LR.FixedHeadTerminalLink ρ out) : out ≤ TShape.bot :=
+  TShape.HasType.bot_r
+    (H TShape.bot (.sort .zero) (LE_Interp.Witness.bot (n := 0)))
+
+/-- **THE ORDERED PEEL'S TERMINAL LAW IS ALSO REFUTABLE**, independently of
+`LR.FixedHeadTerminalRetarget`.  Every consumer of the fixed-head fold carries
+`houtNonbot : ¬out.T ≤ TShape.bot` — the bottom result shape is discharged
+before the telescope is ever consumed — so this Prop is false exactly where it
+would be used.  `LR.FixedHeadProducer.of_orderedLink` is therefore vacuous for
+two independent reasons, and neither is repairable at the leaf. -/
+theorem LR.FixedHeadTerminalLink.not_nonbot {ρ : Valuation} {out : TShape}
+    (hnonbot : ¬out ≤ TShape.bot) : ¬ LR.FixedHeadTerminalLink ρ out :=
+  fun H => hnonbot H.le_bot
+
+/-- One ordered layer step, returning the telescope layer and the peeled
+registered-type witness from ONE declaration.
+
+Returning both halves together is the non-erasing form: a caller cannot pair
+this telescope layer with a type witness peeled at some other domain.
+`peelLayer`'s `hcapDom` is `capture.2.1` here, taken at the domain of the
+very observation the type witness is peeled at. -/
+noncomputable def LR.FixedHeadTelescope.consPeel
+    {Γ₀ : List SExpr} {ρ : Valuation}
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {n : Nat} {f : WShape (n + 1)} {a : WShape n}
+    {m out : TShape} {path : p.Path} {paths : List p.Path}
+    (harg : a.T ≤ mcap path) (happ : m ≤ (f.app a).T)
+    (rest : LE_Interp.RHS.ShapeSpine mcap m paths out)
+    {tyDom : WShape n} {tyFun : WShapeFun n} {argCap : WShape n}
+    {outTy : TShape} {Bdom Bbody : SExpr}
+    (capture : LRS.CaptureDefEqAligned.AtShapes (LR Γ₀)
+      (mcap path) (mx path) (my path) (captureType path) argCap tyDom)
+    (hTy : LE_Interp.Witness ρ (WShape.forallE tyDom tyFun).T
+      (.forallE Bdom Bbody))
+    (hArg : LE_Interp.Witness ρ argCap.T (mx path))
+    (tail : LR.FixedHeadTelescope
+      (headTy := (tyFun.app argCap).T) (outTy := outTy)
+      Γ₀ mx my captureType rest) :
+    PProd
+      (LR.FixedHeadTelescope
+        (headTy := (WShape.forallE tyDom tyFun).T) (outTy := outTy)
+        Γ₀ mx my captureType
+        (LE_Interp.RHS.ShapeSpine.cons harg happ rest))
+      (LE_Interp.Witness ρ (tyFun.app argCap).T (Bbody.inst (mx path))) :=
+  ⟨LR.FixedHeadTelescope.cons harg happ rest capture tail,
+    hTy.forallE_inst hArg⟩
+
+/-- THE ORDERED PRODUCER.  Peel the head's binder layers in order: at every
+layer the registered type's witness is instantiated at the very `argCap` the
+aligned capture is indexed by, so the telescope's captures line up with the
+pattern's ordered path list by construction.
+
+Continuation-passing keeps the produced `outTy` index and the produced
+registered-type witness attached to the same telescope, so the changed third
+premise of `LR.FixedHeadResult` is discharged in one elimination. -/
+theorem LR.FixedHeadTelescope.ofOrderedLink
+    {Γ₀ : List SExpr} {ρ : Valuation}
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head out : TShape}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out)
+    (link : LR.FixedHeadOrderedLink Γ₀ ρ mcap mx my captureType)
+    (term : LR.FixedHeadTerminalLink ρ out) :
+    ∀ {C : Prop} {headTy : TShape} {B : SExpr},
+      LE_Interp.Witness ρ headTy B →
+      (∀ outTy : TShape,
+        LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+          Γ₀ mx my captureType spine → C) → C := by
+  induction spine with
+  | @nil head0 =>
+    intro C headTy B hTy K
+    exact K headTy (LR.FixedHeadTelescope.nil (term headTy B hTy))
+  | @cons n f a m out path paths harg happ rest ih =>
+    intro C headTy B hTy K
+    refine link path a headTy B harg hTy ?_
+    intro tyDom tyFun argCap Bdom Bbody hheadTy hB hargCap capture hArg
+    subst hheadTy
+    subst hB
+    refine ih term (hTy.forallE_inst hArg) ?_
+    intro outTy tail
+    exact K outTy (LR.FixedHeadTelescope.cons harg happ rest capture tail)
+
+/-- **THE REPAIRED ORDERED PRODUCER.**  Peel the head's binder layers in order,
+taking no terminal law whatsoever, and hand the caller both the observation the
+peel actually reached (with its witness) and a *factory* that builds the
+telescope at any result observation the caller can type and compare.
+
+Two things move relative to `LR.FixedHeadTelescope.ofOrderedLink`.
+
+* `LR.FixedHeadTerminalLink` is gone.  It was a law quantified over every
+  observation carrying a witness, and `LE_Interp.Witness.bot` refutes every such
+  law (`LR.FixedHeadTerminalLink.not_nonbot`).  The peel never needed it: the
+  base typing it was used for is the caller's own `out.HasType outTy`.
+* The terminal index is no longer existentially produced and then retargeted.
+  It is an *argument of the factory*, so the caller supplies it — which is the
+  only place `hout`/`hA` are available, since they are inputs of
+  `LR.constDefEq` fixed before any pattern is matched.
+
+What is left over is exactly one comparison, `outTy ≤ reachedTy`, at an
+observation the caller now holds.  That is the entire residual content of
+obstruction O1. -/
+theorem LR.FixedHeadTelescopeLE.ofOrderedLink
+    {Γ₀ : List SExpr} {ρ : Valuation}
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head out : TShape}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out)
+    (link : LR.FixedHeadOrderedLink Γ₀ ρ mcap mx my captureType) :
+    ∀ {C : Prop} {headTy : TShape} {B : SExpr},
+      LE_Interp.Witness ρ headTy B →
+      (∀ (reachedTy : TShape) (Bend : SExpr),
+        LE_Interp.Witness ρ reachedTy Bend →
+        (∀ outTy : TShape, out.HasType outTy → outTy ≤ reachedTy →
+          LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy)
+            Γ₀ mx my captureType spine) → C) → C := by
+  induction spine with
+  | @nil head0 =>
+    intro C headTy B hTy K
+    exact K headTy B hTy
+      (fun _ htyped hle => LR.FixedHeadTelescopeLE.nil htyped hle)
+  | @cons n f a m out path paths harg happ rest ih =>
+    intro C headTy B hTy K
+    refine link path a headTy B harg hTy ?_
+    intro tyDom tyFun argCap Bdom Bbody hheadTy hB hargCap capture hArg
+    subst hheadTy
+    subst hB
+    refine ih (hTy.forallE_inst hArg) ?_
+    intro reachedTy Bend hEnd factory
+    exact K reachedTy Bend hEnd
+      (fun outTy htyped hle =>
+        LR.FixedHeadTelescopeLE.cons harg happ rest capture
+          (factory outTy htyped hle))
+
+/-- The exact interface the changed third premise of `LR.FixedHeadResult`
+consumes: one elimination delivering the ordered capture telescope AND the
+registered type's own semantic witness at ONE shape index, at the caller's
+own result-type observation `outTy.T`.
+
+Continuation-passing is load-bearing.  `LE_Interp.Witness` is `Type`-valued,
+so an existential package would need `Nonempty` and would re-choose the
+index; here no component of the pair is chosen twice, and the telescope and
+the witness provably come from the same peel. -/
+def LR.FixedHeadProducer (Γ₀ : List SExpr) (ρ : Valuation)
+    {n : Nat} {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) {out : WShape (n + 1)} {head : TShape}
+    (mx my captureType :
+      (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+    {outTy : WShape (n + 1)}
+    (hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+      head rule.capturePaths out.T) : Prop :=
+  ∀ {C : Prop},
+    (∀ headTy : TShape,
+      LR.FixedHeadTelescopeLE (headTy := headTy) (outTy := outTy.T)
+        Γ₀ mx my captureType hshape →
+      LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type) → C) → C
+
+/-- Closedness of a registered iota rule's *displayed type*.
+
+`Pattern.IotaRule` carries `rhsClosed` and no `typeClosed` field, but the fact
+is available anyway and needs no new field: the environment's own ordering
+invariant `VEnv.Ordered.closed` closes all three components of every
+registered `VDefEq`.  This discharges the side condition recorded when the
+nil-valuation fixed-head producer was landed. -/
+theorem _root_.Lean4Lean.Pattern.IotaRule.typeClosed
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r) (ls : List SLevel) :
+    (SExpr.mkInst ls rule.df.type).ClosedN :=
+  (Params.henv.closed.2 rule.registered).2.2.mkInstS
+
+/-- THE ISOLATED O1 RESIDUAL: read a finished fixed-head telescope at the
+caller's own result-type observation instead of the one the peel reached.
+
+`WithCaptures.nil` identifies the telescope's two type indices, so the peel's
+terminal observation is a function of the registered type and the aligned
+capture shapes, whereas `outTy` is an *input* of the constant-evaluation fold.
+`LR.constDefEq` receives `hout`/`hA`; it recomputes them only at an
+application layer, and hands them to the pattern leaf unchanged in its `pat`
+branch; `LR.PatternLeafDefEq.of_iota`, `LR.IotaLeafDefEq` and
+`LRS.IotaRHSDefEq` then thread them verbatim.  So `outTy` is already fixed
+before any pattern is matched, and producing `hout`/`hA` "from the peel" is
+not available anywhere at or below the matched leaf.  The whole gap is this
+one retarget, and it is not a lemma: `WithCaptures` has no terminal-index
+monotonicity (the same absence O2 records for its level index), and the
+retarget is an equality of indices, not a comparison.
+
+Its natural producer is a uniqueness statement, not a construction: the peel's
+terminal witness observes the syntactic spine result `A` (the right endpoint
+of `SExpr.PathSpineWF`), and the caller's `hA : (LR Γ₀).TyDefEq A A outTy`
+observes the same `A` at `outTy`. -/
+def LR.FixedHeadTerminalRetarget (Γ₀ : List SExpr)
+    {p : Pattern} {mcap : p.Path → TShape}
+    (mx my captureType : p.Path → SExpr)
+    {head out : TShape} {paths : List p.Path}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out)
+    (outTy : TShape) : Prop :=
+  ∀ {headTy reachedTy : TShape},
+    LR.FixedHeadTelescope (headTy := headTy) (outTy := reachedTy)
+      Γ₀ mx my captureType spine →
+    LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine
+
+/-- **`LR.FixedHeadTerminalRetarget` IS `HasType`-functionality at the
+telescope's terminal head shape**, which is what makes it unprovable as
+stated rather than merely open.
+
+`WithCaptures.nil` (SLR:3661) identifies the two type indices, so at a
+nil-terminated spine the retarget says: every type of `head` equals the
+caller's `outTy`.  `WithCaptures.cons` threads `outTy` unchanged, so on a
+longer spine the same demand simply reappears at the base. -/
+theorem LR.FixedHeadTerminalRetarget.hasType_functional
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr} {head outTy : TShape}
+    (H : LR.FixedHeadTerminalRetarget Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.nil (m2 := mcap) (head := head)) outTy)
+    {headTy : TShape} (htyped : head.HasType headTy) :
+    headTy = outTy := by
+  have tel := H (LR.FixedHeadTelescope.nil (Γ₀ := Γ₀) (mx := mx) (my := my)
+    (captureType := captureType) (mcap := mcap) htyped)
+  cases tel
+  rfl
+
+/-- **THE O1 RESIDUAL AS NAMED IS REFUTABLE.**  `TShape.HasType.bot`
+(SLR:3135) types `.bot` at every sort, so the functionality forced above
+fails outright.
+
+This closes the O1 question in the negative and redirects it: no producer can
+discharge `LR.FixedHeadTerminalRetarget`, because there is nothing to
+discharge — the statement is false.  The previous session's suggested
+"uniqueness statement" producer is refuted along with the Prop.
+
+**REPAIRED.**  The terminal-index monotonicity is
+`LE_Interp.RHS.ShapeSpine.TypedTelescope.WithCapturesLE` (SLR), landed as an
+additive parallel structure; the retarget as a *comparison* is
+`LR.FixedHeadTelescope.retarget`, and the residual it leaves is
+`LR.FixedHeadTerminalDominance`.  The other candidate route — letting
+`LR.FixedHeadShapeChain.pathSemantics` consume a chain at the reached
+observation plus a semantic bridge to `outTy` — is not available: the chain's
+terminal index feeds `LR.FixedHeadApplication` and thence the conclusion of
+`LR.FixedHeadResult` verbatim, so it must literally be the caller's `outTy`,
+and `resultRel` (which is the caller's `hA`) is already consumed there. -/
+theorem LR.FixedHeadTerminalRetarget.not_general
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr} {outTy : TShape} :
+    ¬ LR.FixedHeadTerminalRetarget Γ₀ mx my captureType
+        (LE_Interp.RHS.ShapeSpine.nil (m2 := mcap)
+          (head := TShape.bot)) outTy := by
+  intro H
+  have h1 := LR.FixedHeadTerminalRetarget.hasType_functional H
+    (TShape.HasType.bot' (TShape.HasType.sort (r := true)))
+  have h2 := LR.FixedHeadTerminalRetarget.hasType_functional H
+    (TShape.HasType.bot' (TShape.HasType.sort (r := false)))
+  have hEq : TShape.sort true = TShape.sort false := h1.trans h2.symm
+  simp [TShape, WShape, TShape.sort, WShape.T, WShape.sort] at hEq
+  have h0 : Shape0.sort true = Shape0.sort false := hEq
+  injection h0 with hb
+  exact absurd hb (by decide)
+
+/-- **VACUOUS TWICE OVER — kept only as the reference statement.**  Two of its
+four inputs are refutable: `term` by `LR.FixedHeadTerminalLink.not_nonbot` (at
+every non-bottom result shape, i.e. wherever the fold runs) and `retarget` by
+`LR.FixedHeadTerminalRetarget.not_general`.  It must not be counted as progress
+toward the four leaf-local `producer` hypotheses.
+
+`LR.FixedHeadProducer.of_dominance` below is the live replacement, and
+`LR.FixedHeadTelescopeLE.ofOrderedLink` is the repaired peel it rests on. -/
+theorem LR.FixedHeadProducer.of_orderedLink
+    {Γ₀ : List SExpr} {ρ : Valuation}
+    {n : Nat} {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r} {out : WShape (n + 1)} {head : TShape}
+    {mx my captureType :
+      (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {outTy : WShape (n + 1)}
+    {hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+      head rule.capturePaths out.T}
+    {headTy : TShape}
+    (hTyReg : LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type))
+    (link : LR.FixedHeadOrderedLink Γ₀ ρ (Sum.elim mrec mctor)
+      mx my captureType)
+    (term : LR.FixedHeadTerminalLink ρ out.T)
+    (retarget : LR.FixedHeadTerminalRetarget Γ₀ mx my captureType
+      hshape outTy.T) :
+    LR.FixedHeadProducer Γ₀ ρ rule mx my captureType hshape
+      (recLs := recLs) (outTy := outTy) := by
+  intro C K
+  refine LR.FixedHeadTelescope.ofOrderedLink hshape link term hTyReg ?_
+  intro _reachedTy tel
+  exact K headTy (retarget tel).toLE hTyReg
+
+/-- **THE O1 RESIDUAL, CORRECTLY STATED.**  Some run of the ordered peel
+terminates at an observation that *dominates* the caller's result observation.
+
+This is what survives after the two refutations.  Compare what it replaces:
+
+* `LR.FixedHeadTerminalRetarget` demanded the two observations be *equal*.  That
+  is `HasType`-functionality at the terminal head, and `TShape.HasType.bot`
+  refutes it (`.not_general`).
+* `LR.FixedHeadTerminalLink` demanded a typing at *every* witnessed
+  observation.  `LE_Interp.Witness.bot` refutes it (`.not_nonbot`).
+
+Both failed for the same structural reason: they are laws quantified over
+observations, and the observation lattice has a bottom that every syntax is
+witnessed at.  This Prop is instead *existential in the reached observation* —
+continuation-passing, so the peel's own choice is what is compared — and is
+therefore not refutable by that argument.  `.of_exact` shows it is strictly
+weaker than the demand it replaces; `.nil` inhabits it at exactly the instance
+where the retarget is false. -/
+def LR.FixedHeadTerminalDominance (Γ₀ : List SExpr)
+    {p : Pattern} {mcap : p.Path → TShape}
+    (mx my captureType : p.Path → SExpr)
+    {head out : TShape} {paths : List p.Path}
+    (spine : LE_Interp.RHS.ShapeSpine mcap head paths out)
+    (headTy outTy : TShape) : Prop :=
+  ∀ {C : Prop},
+    (∀ reachedTy : TShape, outTy ≤ reachedTy →
+      LR.FixedHeadTelescope (headTy := headTy) (outTy := reachedTy)
+        Γ₀ mx my captureType spine → C) → C
+
+/-- Faithfulness: the old (exact) demand implies the dominance, at the
+reflexive comparison.  So nothing that used to discharge the producer stops
+discharging it. -/
+theorem LR.FixedHeadTerminalDominance.of_exact
+    {Γ₀ : List SExpr} {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (H : LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine) :
+    LR.FixedHeadTerminalDominance Γ₀ mx my captureType spine headTy outTy :=
+  fun K => K outTy TShape.LE.rfl H
+
+/-- **THE NON-VACUITY CERTIFICATE.**  At the empty capture spine the dominance
+is inhabited from the caller's own result typing alone — including at
+`head = .bot`, which is the very instance at which
+`LR.FixedHeadTerminalRetarget.not_general` derives `False`.  So the replacement
+Prop is genuinely satisfiable where its predecessor was refutable. -/
+theorem LR.FixedHeadTerminalDominance.nil
+    {Γ₀ : List SExpr} {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr} {head outTy : TShape}
+    (htyped : head.HasType outTy) :
+    LR.FixedHeadTerminalDominance Γ₀ mx my captureType
+      (LE_Interp.RHS.ShapeSpine.nil (m2 := mcap) (head := head))
+      outTy outTy :=
+  fun K => K outTy TShape.LE.rfl (LR.FixedHeadTelescope.nil htyped)
+
+/-- The four leaf-local `producer` hypotheses reduce to the registered type's
+own observation, the caller's own result typing, and the terminal dominance.
+
+Everything else the ordered peel needs is proved:
+`LR.FixedHeadTelescopeLE.ofOrderedLink` runs the layers from `link` alone, and
+`LR.FixedHeadTelescope.retarget` moves the finished telescope down to the
+caller's observation.  Contrast `LR.FixedHeadProducer.of_orderedLink`, which is
+vacuous twice over. -/
+theorem LR.FixedHeadProducer.of_dominance
+    {Γ₀ : List SExpr} {ρ : Valuation}
+    {n : Nat} {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r} {out : WShape (n + 1)} {head : TShape}
+    {mx my captureType :
+      (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {outTy : WShape (n + 1)}
+    {hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+      head rule.capturePaths out.T}
+    {headTy : TShape}
+    (hTyReg : LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type))
+    (hout : out.HasType outTy)
+    (dom : LR.FixedHeadTerminalDominance Γ₀ mx my captureType
+      hshape headTy outTy.T) :
+    LR.FixedHeadProducer Γ₀ ρ rule mx my captureType hshape
+      (recLs := recLs) (outTy := outTy) := by
+  intro C K
+  refine dom ?_
+  intro reachedTy hle tel
+  exact K headTy (tel.retarget hout.T hle) hTyReg
+
+/-- Logical-relation congruence for one generated iota RHS at adjacent
+stratification levels.  The two endpoints share the rule's ordered paths and
+one exact capture-type map; each variable leaf is therefore related at the
+very domain used by both dependent application spines.  The eventual
+constructor proves the fixed-tower case by `LE_Interp.recR`; no environment
+or reduction oracle appears in this contract. -/
+def LRS.IotaRHSDefEq
+    (IH : LogRel Γ n) (R : TShape → SExpr → Prop)
+    {rec ctor : Name} {major arity : Nat}
+    (recLs : List SLevel)
+    (mrec : (Pattern.varN (.const rec) major).Path → TShape)
+    (mctor : (Pattern.varN (.const ctor) arity).Path → TShape)
+    (r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check)
+    (rule : Pattern.IotaRule r)
+    (out : WShape (n + 1)) : Prop :=
+  LE_Interp.RHS recLs (Sum.elim mrec mctor) R out.T r.1 →
+  ∀ {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+      {A : SExpr} {outTy : WShape (n + 1)},
+    SExpr.PathSpineWF Γ mx captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    SExpr.PathSpineWF Γ my captureType
+      (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+    (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+      match path with
+      | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+          (mx path) (my path) (captureType path)
+      | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+          (mx path) (my path) (captureType path)) →
+    out.HasType outTy →
+    (LRS IH).TyDefEq A A outTy →
+    (LRS IH).DefEq
+      (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy
+
+/-- Build the full generated-RHS contract from its only nontrivial case.
+`RHS.bot` is discharged uniformly; the continuation receives the semantic
+fixed head, its environment-derived strong self-typing, and the exact ordered
+application chain extracted from the rule.  It also receives a typed lower
+approximation of that head.  This last witness is the admissible argument to
+the surrounding `LE_Interp.recR` induction: capture materialization supplies
+logical witnesses only at the selected arguments, and therefore cannot by
+itself manufacture validity of the registered head's universally quantified
+type. -/
+theorem LRS.IotaRHSDefEq.of_nonbot
+    {IH : LogRel Γ n} {R : TShape → SExpr → Prop}
+    {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r} {out : WShape (n + 1)}
+    (H : ∀ {head : TShape}
+        {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {captureType :
+          (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {A : SExpr} {outTy : WShape (n + 1)},
+      LE_Interp.RHS (p := RecursorIotaPattern rec major ctor arity)
+        recLs (Sum.elim mrec mctor) R head
+        (.fixed rule.df.rhs rule.rhsClosed) →
+      IsDefEqStrong Γ (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.type) →
+      LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T →
+      (∃ headElem headTy : TShape,
+        headElem ≤ head ∧ headElem.HasType headTy) →
+      SExpr.PathSpineWF Γ mx captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      SExpr.PathSpineWF Γ my captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+        match path with
+        | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+            (mx path) (my path) (captureType path)
+        | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+            (mx path) (my path) (captureType path)) →
+      out.HasType outTy →
+      (LRS IH).TyDefEq A A outTy →
+      (LRS IH).DefEq
+        (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy) :
+    LRS.IotaRHSDefEq IH R recLs mrec mctor r rule out := by
+  intro hrhs mx my captureType A outTy hspineX hspineY hcap hout hA
+  obtain hbot | ⟨head, hhead, hshapeSpine⟩ := rule.rhsShapeSpine hrhs
+  · have houtBot : out = .bot := TShape.le_bot.1 hbot
+    subst out
+    exact (LRS IH).bot hout.isType
+  · have hcapTyped : ∀ path,
+        ∃ elem elemTy : TShape,
+          Sum.elim mrec mctor path ≤ elem ∧ elem.HasType elemTy := by
+      intro path
+      cases path with
+      | inl path =>
+        obtain ⟨elem, elemTy, hshape, htype, _⟩ := hcap (.inl path)
+        exact ⟨elem.T, elemTy.T, hshape, htype.T⟩
+      | inr path =>
+        obtain ⟨elem, elemTy, hshape, htype, _⟩ := hcap (.inr path)
+        exact ⟨elem.T, elemTy.T, hshape, htype.T⟩
+    have hheadTyped := hshapeSpine.typedLowerHead hcapTyped hout.T
+    exact H hhead (rule.rhsStrong recLs) hshapeSpine hheadTyped
+      hspineX hspineY hcap hout hA
+
+/-- Witness-aware form of `IotaRHSDefEq.of_nonbot` for a constant evaluator
+using `LE_Interp.Lower R`.  The callback receives the exact proof-relevant
+fixed-head witness selected by the enclosing constant's `R` callback; no
+propositional derivation identity has to survive this boundary. -/
+theorem LRS.IotaRHSDefEq.of_nonbotWitness
+    {IH : LogRel Γ n} {R : TShape → SExpr → Prop}
+    {ρ : Valuation}
+    {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r} {out : WShape (n + 1)}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (H : ∀ {head : TShape}
+        {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {captureType :
+          (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {A : SExpr} {outTy : WShape (n + 1)},
+      LE_Interp.Witness ρ head (SExpr.mkInst recLs rule.df.rhs) →
+      IsDefEqStrong Γ (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.type) →
+      LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T →
+      (∃ headElem headTy : TShape,
+        headElem ≤ head ∧ headElem.HasType headTy) →
+      SExpr.PathSpineWF Γ mx captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      SExpr.PathSpineWF Γ my captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+        match path with
+        | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+            (mx path) (my path) (captureType path)
+        | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+            (mx path) (my path) (captureType path)) →
+      out.HasType outTy →
+      (LRS IH).TyDefEq A A outTy →
+      (LRS IH).DefEq
+        (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy) :
+    LRS.IotaRHSDefEq IH (LE_Interp.Lower R)
+      recLs mrec mctor r rule out := by
+  apply LRS.IotaRHSDefEq.of_nonbot
+  intro head mx my captureType A outTy hhead hstrong hshape htyped
+    hspineX hspineY hcap hout hA
+  exact H (hhead.fixedLowerWitness hR) hstrong hshape htyped
+    hspineX hspineY hcap hout hA
+
+/-- Recursive-result-preserving form of `of_nonbotWitness`.
+
+The fixed head is selected from an abstract `R` edge of the enclosing
+constant.  Its recursive hypothesis must be selected at the same time: a
+second proof-relevant witness with identical public indices may carry a
+different abstract relation.  `hmono` transports that hypothesis through
+the root-only lowering performed by `LE_Interp.Lower`. -/
+theorem LRS.IotaRHSDefEq.of_nonbotWitnessResult
+    {IH : LogRel Γ n} {R : TShape → SExpr → Prop}
+    {ρ : Valuation}
+    {P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop}
+    {rec ctor : Name} {major arity : Nat}
+    {recLs : List SLevel}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r} {out : WShape (n + 1)}
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hP : ∀ {m M} (hr : R m M), P (hR hr))
+    (hmono : ∀ {m m' M} (hle : m ≤ m')
+      (hM : LE_Interp.Witness ρ m' M), P hM → P (hM.mono hle))
+    (H : ∀ {head : TShape}
+        {mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {captureType :
+          (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+        {A : SExpr} {outTy : WShape (n + 1)}
+        (hhead : LE_Interp.Witness ρ head
+          (SExpr.mkInst recLs rule.df.rhs)),
+      P hhead →
+      IsDefEqStrong Γ (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.type) →
+      LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T →
+      (∃ headElem headTy : TShape,
+        headElem ≤ head ∧ headElem.HasType headTy) →
+      SExpr.PathSpineWF Γ mx captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      SExpr.PathSpineWF Γ my captureType
+        (SExpr.mkInst recLs rule.df.type) rule.capturePaths A →
+      (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+        match path with
+        | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+            (mx path) (my path) (captureType path)
+        | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+            (mx path) (my path) (captureType path)) →
+      out.HasType outTy →
+      (LRS IH).TyDefEq A A outTy →
+      (LRS IH).DefEq
+        (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy) :
+    LRS.IotaRHSDefEq IH (LE_Interp.Lower R)
+      recLs mrec mctor r rule out := by
+  intro hrhs mx my captureType A outTy hspineX hspineY hcap hout hA
+  by_cases houtBot : out.T ≤ TShape.bot
+  · have houtEq : out = .bot := TShape.le_bot.1 houtBot
+    subst out
+    exact (LRS IH).bot hout.isType
+  obtain hbot | ⟨head, hhead, hshapeSpine⟩ := rule.rhsShapeSpine hrhs
+  · exact (houtBot hbot).elim
+  have hheadNonbot : ¬head ≤ TShape.bot := by
+    intro hbot
+    exact houtBot (hshapeSpine.le_bot hbot)
+  have hcapTyped : ∀ path,
+      ∃ elem elemTy : TShape,
+        Sum.elim mrec mctor path ≤ elem ∧ elem.HasType elemTy := by
+    intro path
+    cases path with
+    | inl path =>
+      obtain ⟨elem, elemTy, hshape, htype, _⟩ := hcap (.inl path)
+      exact ⟨elem.T, elemTy.T, hshape, htype.T⟩
+    | inr path =>
+      obtain ⟨elem, elemTy, hshape, htype, _⟩ := hcap (.inr path)
+      exact ⟨elem.T, elemTy.T, hshape, htype.T⟩
+  have hheadTyped := hshapeSpine.typedLowerHead hcapTyped hout.T
+  let headResult :=
+    hhead.fixedLowerWitnessResult hR hP hmono hheadNonbot
+  exact H headResult.1 headResult.2 (rule.rhsStrong recLs)
+    hshapeSpine hheadTyped hspineX hspineY hcap hout hA
+
+/-- The exact constructor case of iota materialization with explicit typing
+certificates for the reached contraction sites.  Keeping these certificates
+as callbacks lets native leaves discharge them by reflexivity, while callers
+with genuinely reducing majors may derive them through their chosen subject-
+reduction theorem. -/
+theorem LR.iotaActions_of_exactEqAt
+    {n : Nat} {IH : LogRel Γ₀ n} {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs ctorXs ctorYs : List SExpr}
+    {recLs ctorLs ctorLs' : List SLevel}
+    {majorX majorY A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrecargs : LRS.CtorArgsDefEq (LRS IH) recXs recYs recShapes)
+    (hctorargs : LRS.CtorArgsDefEq IH ctorXs ctorYs ctorShapes)
+    (hMajorX : Γ₀ ⊢ majorX ⤳*
+      ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs))
+    (hMajorY : Γ₀ ⊢ majorY ⤳*
+      ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs'))
+    (hsiteTypeX : ∀ (_ : Γ₀ ⊢
+      (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app majorX ⤳*
+        (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs))),
+      Γ₀ ⊢
+        (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)) : A)
+    (hsiteTypeY : ∀ (_ : Γ₀ ⊢
+      (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app majorY ⤳*
+        (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs'))),
+      Γ₀ ⊢
+        (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')) : A)
+    (hAType : ∃ u, Γ₀ ⊢ A : .sort u)
+    {recHeadType ctorHeadTypeX ctorHeadTypeY ctorResultX ctorResultY
+      majorType : SExpr}
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hrecSpineX : SExpr.SpineWF Γ₀ recHeadType
+      (recXs.reverse ++ [majorX]) A)
+    (hrecSpineY : SExpr.SpineWF Γ₀ recHeadType
+      (recYs.reverse ++ [majorY]) A)
+    (hctorHeadX : Γ₀ ⊢ .const ctor ctorLs : ctorHeadTypeX)
+    (hctorHeadY : Γ₀ ⊢ .const ctor ctorLs' : ctorHeadTypeY)
+    (hctorSpineX : SExpr.SpineWF Γ₀ ctorHeadTypeX
+      ctorXs.reverse ctorResultX)
+    (hctorSpineY : SExpr.SpineWF Γ₀ ctorHeadTypeY
+      ctorYs.reverse ctorResultY)
+    (hMajorEqX : Γ₀ ⊢ majorX ≡
+      ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs) : majorType)
+    (hMajorEqY : Γ₀ ⊢ majorY ≡
+      ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs') : majorType) :
+    ∃ (mx my : (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      (captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      (captureTypingX : Pattern.CaptureTyping Γ₀ mx captureType)
+      (captureTypingY : Pattern.CaptureTyping Γ₀ my captureType)
+      (rule : Pattern.IotaRule r)
+      (siteX : Pattern.IotaReductionSite Γ₀ r rule recLs ctorLs
+        recXs ctorXs majorX A mx captureType captureTypingX)
+      (siteY : Pattern.IotaReductionSite Γ₀ r rule recLs ctorLs'
+        recYs ctorYs majorY A my captureType captureTypingY),
+      ∃ actionX : Pattern.Action Γ₀ r
+        ((recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorXs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs)))
+        recLs mx A,
+      ∃ actionY : Pattern.Action Γ₀ r
+        ((recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app
+          (ctorYs.foldr (fun (a f : SExpr) => f.app a) (.const ctor ctorLs')))
+        recLs my A,
+      (∀ path : (RecursorIotaPattern rec major ctor arity).Path,
+        match path with
+        | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+            (mx path) (my path) (captureType path)
+        | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+            (mx path) (my path) (captureType path)) ∧
+      Γ₀ ⊢
+        (recXs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app majorX ⤳*
+          r.1.applyS recLs mx ∧
+      Γ₀ ⊢
+        (recYs.foldr (fun (a f : SExpr) => f.app a) (.const rec recLs)).app majorY ⤳*
+          r.1.applyS recLs my := by
+  obtain ⟨mx, my, hmatchX, hmatchY, hcap, hredX, hredY⟩ :=
+    LE_Interp.Matches.iota_materialize_exactAt hpat hmf hma
+      hrecargs hctorargs hMajorX hMajorY
+  let typingX : Pattern.IotaTyping Γ₀ rec ctor recLs ctorLs
+      recXs ctorXs majorX A := {
+    recHeadType := recHeadType
+    ctorHeadType := ctorHeadTypeX
+    ctorResultType := ctorResultX
+    majorType := majorType
+    recHead := hrecHead
+    recSpine := hrecSpineX
+    ctorHead := hctorHeadX
+    ctorSpine := hctorSpineX
+    majorEq := hMajorEqX }
+  let typingY : Pattern.IotaTyping Γ₀ rec ctor recLs ctorLs'
+      recYs ctorYs majorY A := {
+    recHeadType := recHeadType
+    ctorHeadType := ctorHeadTypeY
+    ctorResultType := ctorResultY
+    majorType := majorType
+    recHead := hrecHead
+    recSpine := hrecSpineY
+    ctorHead := hctorHeadY
+    ctorSpine := hctorSpineY
+    majorEq := hMajorEqY }
+  classical
+  let captureType : (RecursorIotaPattern rec major ctor arity).Path → SExpr :=
+    fun path => match path with
+      | Sum.inl p => (LRS.CaptureDefEqAt.witness (hcap (Sum.inl p))).typeExpr
+      | Sum.inr p => (LRS.CaptureDefEqAt.witness (hcap (Sum.inr p))).typeExpr
+  let captureTypingX : Pattern.CaptureTyping Γ₀ mx captureType := {
+    typed := by
+      intro path
+      cases path with
+      | inl p =>
+        exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inl p))).defeq.hasType.1
+      | inr p =>
+        exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inr p))).defeq.hasType.1 }
+  let captureTypingY : Pattern.CaptureTyping Γ₀ my captureType := {
+    typed := by
+      intro path
+      cases path with
+      | inl p =>
+        exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inl p))).defeq.hasType.2
+      | inr p =>
+        exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inr p))).defeq.hasType.2 }
+  let rule := Params.Semantic.iotaRule hpat
+  let siteX := Params.Semantic.iotaSite rule captureType captureTypingX hΓ.reify
+    typingX hmatchX
+    (hsiteTypeX hredX) hAType
+  let siteY := Params.Semantic.iotaSite rule captureType captureTypingY hΓ.reify
+    typingY hmatchY
+    (hsiteTypeY hredY) hAType
+  let actionX := siteX.action
+  let actionY := siteY.action
+  have hcapAligned : ∀ path :
+      (RecursorIotaPattern rec major ctor arity).Path,
+      match path with
+      | Sum.inl p => LRS.CaptureDefEqAligned (LRS IH) (mrec p)
+          (mx path) (my path) (captureType path)
+      | Sum.inr p => LRS.CaptureDefEqAligned IH (mctor p)
+          (mx path) (my path) (captureType path) := by
+    intro path
+    cases path with
+    | inl p =>
+      exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inl p))).aligned
+    | inr p =>
+      exact (LRS.CaptureDefEqAt.witness (hcap (Sum.inr p))).aligned
+  exact ⟨mx, my, captureType, captureTypingX, captureTypingY,
+    rule, siteX, siteY, actionX, actionY, hcapAligned,
+    .tail hredX (.extra actionX), .tail hredY (.extra actionY)⟩
+
+/-- Consume a native exact constructor leaf without appealing to generic
+weak-head subject reduction.
+
+At this boundary both majors already *are* their classified constructor
+spines.  `CtorExact` supplies the constructor head/spine certificates and
+related fields, while `PatternLeafSpine` supplies the recursor spine, its
+last Pi, and the majors' common domain typing.  Both majors' weak-head
+observations are reflexive here and every remaining typing is projected
+from those two certificates.  This is the exact handler used after a
+`CtorFrame` has reached its native leaf. -/
+theorem LRS.iotaDefEq_of_ctorExactAt
+    {n : Nat} {IH : LogRel Γ₀ n}
+    {R : TShape → SExpr → Prop}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      R out.T r.1)
+    (leaf : LRS.CtorExact Γ₀ IH majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LRS IH) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LRS IH).TyDefEq A A outTy)
+    (rhsDefEq : ∀ rule : Pattern.IotaRule r,
+      LRS.IotaRHSDefEq IH R recLs mrec mctor r rule out) :
+    (LRS IH).DefEq
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy := by
+  generalize hm : WShape.ctor ctor ctorShapes.reverse hwf = m at leaf
+  cases leaf with
+  | @intro _ ctorLeafShapes _ ctorLs ctorLs' ctorXs ctorYs
+      ctorHeadTypeX ctorHeadTypeY ctorResultX ctorResultY
+      hctorClass hctorLenX hctorLenY hctorLevels hctorHeadX hctorHeadY
+      hctorSpineX hctorSpineY hctorArgs hctorAligned hctorMirror =>
+    subst ctorLs'
+    obtain ⟨rfl, hctorShapes⟩ := WShape.ctor.inj.1 hm
+    have hctorShapes' : ctorShapes = ctorLeafShapes := by
+      exact List.reverse_inj.1 hctorShapes
+    subst ctorShapes
+    have hterm : Γ₀ ⊢
+        ((recXs.foldr (fun (a f : SExpr) => f.app a)
+          (.const rec recLs)).app
+            (ctorXs.foldr (fun (a f : SExpr) => f.app a)
+              (.const ctor ctorLs))) ≡
+        ((recYs.foldr (fun (a f : SExpr) => f.app a)
+          (.const rec recLs)).app
+            (ctorYs.foldr (fun (a f : SExpr) => f.app a)
+              (.const ctor ctorLs))) : A := by
+      simpa only [List.foldl_reverse, List.foldr_cons] using
+        hleaf.aligned.spine.congr hrecHead
+    have hAType : ∃ u, Γ₀ ⊢ A : .sort u :=
+      ⟨hleaf.pair.resultSortX, hleaf.pair.resultX.hasType.2⟩
+    have hrecSpineX := hleaf.pair.fullX
+    rw [← hleaf.args_eq] at hrecSpineX
+    simp only [List.reverse_cons] at hrecSpineX
+    have hrecSpineY := hleaf.pair.fullY
+    rw [← hleaf.args'_eq] at hrecSpineY
+    simp only [List.reverse_cons] at hrecSpineY
+    obtain ⟨_, hmajor⟩ := hleaf.majorDefEq
+    obtain ⟨mx, my, captureType, captureTypingX, captureTypingY,
+        rule, siteX, siteY, actionX, actionY, hcap, hredX, hredY⟩ :=
+      LR.iotaActions_of_exactEqAt (IH := IH) hΓ hpat hmf hma
+        hleaf.args.tail hctorArgs .rfl .rfl
+        (fun _ => hterm.hasType.1) (fun _ => hterm.hasType.2)
+        hAType hrecHead
+      hrecSpineX hrecSpineY
+      hctorHeadX hctorHeadY hctorSpineX hctorSpineY
+      hmajor.hasType.1 hmajor.hasType.2
+    have hrhsDefEq : (LRS IH).DefEq
+        (r.1.applyS recLs mx) (r.1.applyS recLs my) A out outTy :=
+      rhsDefEq rule hrhs siteX.captureSpine siteY.captureSpine hcap hout hA
+    exact ((LRS IH).whr hredX hredY).2 hrhsDefEq
+
+/-- Consume one native constructor leaf as a synchronized iota rectangle.
+
+The two row edges reuse respectively the left and right recursor prefixes
+while keeping the original related constructor majors.  The diagonal reuses
+the original cross-prefix leaf.  Thus all three contractions have one result
+shape and one left-oriented dependent result type, which is the invariant
+needed by normalized-chain composition. -/
+theorem LRS.iotaDefEqRect_of_ctorExactAt
+    {n : Nat} {IH : LogRel Γ₀ n}
+    {R : TShape → SExpr → Prop}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      R out.T r.1)
+    (leaf : LRS.CtorExact Γ₀ IH majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LRS IH) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LRS IH).TyDefEq A A outTy)
+    (rhsDefEq : ∀ rule : Pattern.IotaRule r,
+      LRS.IotaRHSDefEq IH R recLs mrec mctor r rule out) :
+    LogRel.DefEqRect (LRS IH)
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy := by
+  refine ⟨?_, ?_, ?_⟩
+  · exact LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf
+      hleaf.leftPrefixes hrecHead hout hA rhsDefEq
+  · exact LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf
+      hleaf.rightPrefixes hrecHead hout hA rhsDefEq
+  · exact LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf
+      hleaf hrecHead hout hA rhsDefEq
+
+/-- Close one native exact iota leaf from proof-relevant fixed-head results.
+
+The semantic `R` callback and its recursive result are selected together,
+so lowering the reached head cannot silently reselect a different constant
+evaluator.  This is the exact-leaf half of the final normalized consumer:
+constructor materialization remains local, while the generated RHS is
+discharged by the proof-independent canonical `FixedHeadResult`. -/
+theorem LRS.iotaDefEq_of_ctorExactAt_fixedHead
+    {n : Nat}
+    {R : TShape → SExpr → Prop} {ρ : Valuation}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    {Δ : List SExpr} {σ σ' : Subst}
+    (W : LR.SubstWF Γ₀ σ σ' Δ ρ)
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      (LE_Interp.Lower R) out.T r.1)
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hP : ∀ {m M} (hr : R m M), LR.FixedHeadResult Γ₀ (hR hr))
+    (producer : ∀ (rule : Pattern.IotaRule r) {head : TShape}
+      (mx my captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      {outTyP : WShape (n + 1)}
+      (hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T),
+      LR.FixedHeadProducer Γ₀ ρ rule mx my captureType hshape
+        (recLs := recLs) (outTy := outTyP))
+    (leaf : LRS.CtorExact Γ₀ (LR Γ₀) majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LR Γ₀) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LR Γ₀).TyDefEq A A outTy) :
+    (LR Γ₀).DefEq
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy := by
+  apply LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf hleaf
+    hrecHead hout hA
+  intro rule
+  apply LRS.IotaRHSDefEq.of_nonbotWitnessResult
+    (P := fun h => LR.FixedHeadResult Γ₀ h) hR hP
+  · intro m m' M hle hM H
+    exact LR.FixedHeadResult.mono (ρ := ρ) (hX := hM) hle H
+  · intro head mx my captureType A outTy hhead hfixed _hstrong hshape
+      _htyped hspineX hspineY hcap hout hA
+    refine producer rule mx my captureType hshape (outTyP := outTy) ?_
+    intro headTy htel hTyReg
+    exact hfixed W rfl .rfl (rule.rhsStrong recLs) hshape htel hTyReg
+      hspineX hspineY hcap hout hA
+
+/-- Close one native exact iota leaf from closed-valuation fixed-head
+results.
+
+`FixedHeadResult` is consumed through `LR.SubstWF`, whose only closed
+constructor pins the valuation to `Valuation.nil`, while an abstract
+constant evaluator observes its registered fixed heads at an arbitrary
+caller valuation with no fits certificate.  The registered RHS is closed,
+so the selected head witness is transported to `Valuation.nil` at the same
+root shape before its fixed-head result is consumed at the identity
+substitution.  Nothing is truncated by this move: the semantic spine, the
+typed lower head, both raw capture telescopes, and the aligned logical
+captures are already valuation-free, and `Witness.closedAt` preserves the
+entire evaluator tree of the selected witness rather than reselecting a
+public interpretation. -/
+theorem LRS.iotaDefEq_of_ctorExactAt_closedFixedHead
+    {n : Nat}
+    {R : TShape → SExpr → Prop} {ρ : Valuation}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      (LE_Interp.Lower R) out.T r.1)
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (fixedHead : ∀ {root : TShape} {X : SExpr}
+      (hX : LE_Interp.Witness Valuation.nil root X),
+      LR.FixedHeadResult Γ₀ hX)
+    (producer : ∀ (rule : Pattern.IotaRule r) {head : TShape}
+      (mx my captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      {outTyP : WShape (n + 1)}
+      (hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T),
+      LR.FixedHeadProducer Γ₀ Valuation.nil rule mx my captureType hshape
+        (recLs := recLs) (outTy := outTyP))
+    (leaf : LRS.CtorExact Γ₀ (LR Γ₀) majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LR Γ₀) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LR Γ₀).TyDefEq A A outTy) :
+    (LR Γ₀).DefEq
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy := by
+  apply LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf hleaf
+    hrecHead hout hA
+  intro rule
+  apply LRS.IotaRHSDefEq.of_nonbotWitness hR
+  intro head mx my captureType A' outTy' hhead hstrong hshape
+    _htyped hspineX hspineY hcap hout' hA'
+  have hclosed : (SExpr.mkInst recLs rule.df.rhs).ClosedN :=
+    rule.rhsClosed.mkInstS
+  refine producer rule mx my captureType hshape (outTyP := outTy') ?_
+  intro headTy htel hTyReg
+  exact fixedHead (hhead.closedAt hclosed) LR.SubstWF.id rfl .rfl
+    hstrong hshape htel hTyReg hspineX hspineY hcap hout' hA'
+
+/-- A proof of the iota-only leaf contract discharges every nonempty simple
+pattern leaf. -/
+theorem LR.PatternLeafDefEq.of_iota
+    (H : LR.IotaLeafDefEq Γ₀ c ls R) :
+    LR.PatternLeafDefEq Γ₀ c ls R := by
+  intro n rargs p r mcap xs ys CHead A out outTy
+    hpat hmatch hrhs hleaf hterm hAType hhead hspineX hspineY hout hA
+  obtain ⟨rec, major, ctor, arity, rfl⟩ :=
+    hmatch.iota_of_pat_nonempty hpat hleaf.nonempty
+  exact H hpat hmatch hrhs hleaf hterm hAType hhead hspineX hspineY hout hA
+
+/-- Evaluate a semantic constant using exact related syntax for its accumulated
+application spine.  All structural cases are discharged here; a caller only
+supplies the finite, proof-carrying action at a reached pattern leaf.  The
+extra `rargs'` layer is essential: recursive semantic function layers may
+change shape depth, while the already accumulated spine must only be lifted
+or enlarged, never projected. -/
+theorem LR.constDefEq
+    {c : Name} {ls : List SLevel} {R : TShape → SExpr → Prop}
+    (hRmono : ∀ {m m' M}, m ≤ m' → R m' M → R m M)
+    {n : Nat} {rargs : List (WShape n)} {mout : TShape}
+    (hC : LE_Interp.Const c ls R rargs mout)
+    {n' : Nat} {rargs' : List (WShape n')}
+    {xs ys : List SExpr} {CHead A : SExpr} {out outTy : WShape n'}
+    (evalPat : LR.PatternLeafDefEqAt Γ₀ n' c ls R)
+    (hargle : List.Forall₂ (fun x y => x.T ≤ y.T) rargs rargs')
+    (hleaf : LR.PatternLeafSpine Γ₀ (LR Γ₀)
+      CHead xs ys rargs' A out outTy)
+    (hterm : Γ₀ ⊢
+      (xs.foldr (fun a f => f.app a) (.const c ls)) ≡
+      (ys.foldr (fun a f => f.app a) (.const c ls)) : A)
+    (hAType : ∃ u, Γ₀ ⊢ A : .sort u)
+    (hhead : Γ₀ ⊢ .const c ls : CHead)
+    (hspineX : SExpr.SpineWF Γ₀ CHead xs.reverse A)
+    (hspineY : SExpr.SpineWF Γ₀ CHead ys.reverse A)
+    (hout : out.HasType outTy)
+    (hA : (LR Γ₀).TyDefEq A A outTy)
+    (houtle : out.T ≤ mout) :
+    (LR Γ₀).DefEq
+      (xs.foldr (fun a f => f.app a) (.const c ls))
+      (ys.foldr (fun a f => f.app a) (.const c ls)) A out outTy := by
+  induction hC generalizing rargs' xs ys A out outTy with
+  | bot =>
+    have hb : out.T ≤ TShape.bot := houtle.trans TShape.bot_eqv.1
+    have heq : out = .bot := TShape.le_bot.1 hb
+    subst out
+    exact (LR Γ₀).bot hout.isType
+  | pat hpat hmatch hrhs =>
+    obtain ⟨mcap', hmatch', hcap⟩ :=
+      hmatch.mono_lT (Params.pat_wf hpat) hargle
+    have hrhs' : LE_Interp.RHS ls mcap' R out.T _ :=
+      (hrhs.mono_l hcap).mono (R' := R) houtle
+        (fun le hr => hRmono le hr)
+    exact evalPat hpat hmatch' hrhs' hleaf hterm hAType
+      hhead hspineX hspineY hout hA
+  | @lam f rargs mout hrec hlam ih =>
+    have hlam₀ := houtle.trans hlam
+    have hlam' := hlam₀
+    cases hout.unfold with
+    | bot hm => exact (LR Γ₀).bot hm
+    | sort => exact (TShape.sort_not_le_lam' hlam').elim
+    | forallE => exact (TShape.forallE_not_le_lam' hlam').elim
+    | @lam q g a₁ a₂ htm =>
+      rw [LR_succ] at hA ⊢
+      unfold WShape.lam' at hlam' ⊢
+      split at hlam' <;> rename_i hg
+      · obtain ⟨B₁, F₁, B₂, F₂, u, v, rA, _, hB, hF, hValB, hPi₀⟩ := hA
+        have hPi := LRS.PiDefEq.left hPi₀
+        have evalChild : ∀ {K : Nat}, K = q + 1 → ∀
+            {x y : SExpr} {p : WShape K} {x₀ y₀ : WShape n}
+            {zs zs' : List SExpr},
+            LRS.CtorSpineDefEq (LR Γ₀) CHead zs zs' rargs' A →
+            Γ₀ ⊢
+              (zs.foldr (fun a f => f.app a) (.const c ls)) ≡
+              (zs'.foldr (fun a f => f.app a) (.const c ls)) : A →
+            SExpr.SpineWF Γ₀ CHead zs.reverse A →
+            SExpr.SpineWF Γ₀ CHead zs'.reverse A →
+            p.HasType (a₁.lift K) →
+            Γ₀ ⊢ x ≡ y : B₁ →
+            (LR Γ₀).DefEq x y B₁ p (a₁.lift K) →
+            (x₀, y₀) ∈ f → x₀.T ≤ p.T →
+            ((g.lift K).app p).T ≤ y₀.T →
+            (LR Γ₀).DefEq
+              ((zs.foldr (fun a (acc : SExpr) => acc.app a) (SExpr.const c ls)).app x)
+              ((zs'.foldr (fun a (acc : SExpr) => acc.app a) (SExpr.const c ls)).app y)
+              (F₁.inst x) ((g.lift K).app p)
+                ((a₂.lift K).app p) := by
+          intro K hK
+          subst K
+          intro x y p x₀ y₀ zs zs' htailAligned htailTerm
+            htailSpineX htailSpineY hp hxy hv hmem hx hy
+          have hchildLe : List.Forall₂ (fun x y => x.T ≤ y.T)
+              (x₀ :: rargs) (p :: rargs') := by
+            exact .cons hx hargle
+          have hBK : (LR Γ₀).TyDefEq B₁ B₁ (a₁.lift (q + 1)) :=
+            (LR.TyDefEq.lift (Nat.le_succ q)
+              (WShape.HasTypePi.iff.1 htm.1).1.isType).2
+              ((LR Γ₀).left_ty hValB)
+          have htmK : WShape.HasTypeLam (g.lift (q + 1))
+              (a₁.lift (q + 1)) (a₂.lift (q + 1)) :=
+            (WShape.HasTypeLam.lift (Nat.le_succ q)).2 htm
+          have houtK : ((g.lift (q + 1)).app p).HasType
+              ((a₂.lift (q + 1)).app p) :=
+            (WShape.HasTypeLam.iff.1 htmK).2.2 p hp
+          have hPiK : LRS.PiDefEq (LR Γ₀) B₁ F₁ F₁
+              (a₁.lift (q + 1)) (a₂.lift (q + 1)) :=
+            (LRS.PiDefEq.lift (Nat.le_succ q) htm.1).2 hPi
+          have hAK : (LR Γ₀).TyDefEq (F₁.inst x) (F₁.inst x)
+              ((a₂.lift (q + 1)).app p) :=
+            hPiK.2 hp hxy.hasType.1 ((LR Γ₀).left hv)
+          obtain ⟨uA, hAType⟩ := hAType
+          have hAeqPi : Γ₀ ⊢ A ≡ .forallE B₁ F₁ : .sort uA :=
+            rA.defeq hAType
+          have htailPi : Γ₀ ⊢
+              (zs.foldr (fun a f => f.app a) (.const c ls)) ≡
+              (zs'.foldr (fun a f => f.app a) (.const c ls)) :
+                .forallE B₁ F₁ :=
+            hAeqPi.defeqDF htailTerm
+          have hchildTerm : Γ₀ ⊢
+              (zs.foldr (fun a (f : SExpr) => f.app a) (SExpr.const c ls)).app x ≡
+              (zs'.foldr (fun a (f : SExpr) => f.app a) (SExpr.const c ls)).app y :
+                F₁.inst x :=
+            .appDF htailPi hxy
+          have hchildType : Γ₀ ⊢ F₁.inst x : .sort v :=
+            (IsDefEq.beta hF.leftType hxy.hasType.1).hasType.2
+          have hchildSpineX : SExpr.SpineWF Γ₀ CHead
+              (x :: zs).reverse (F₁.inst x) := by
+            simpa only [List.reverse_cons] using
+              htailSpineX.snoc hAeqPi hxy.hasType.1
+          obtain ⟨_, hCodomain⟩ := (hPiK.1 hp hxy hv).leftDefEq
+          have hchildAligned : LRS.CtorSpineDefEq (LR Γ₀) CHead
+              (x :: zs) (y :: zs')
+              (p :: rargs') (F₁.inst x) :=
+            .cons htailAligned hAeqPi hp hBK hxy hv hCodomain.symm
+          have hchildSpineY : SExpr.SpineWF Γ₀ CHead
+              (y :: zs').reverse (F₁.inst x) := by
+            have hspine := htailSpineY.snoc hAeqPi hxy.hasType.2
+            simpa only [List.reverse_cons] using
+              SExpr.SpineWF.ret hspine hCodomain.symm
+          let hchildPair : SExpr.SpineWF.LastPair Γ₀ CHead
+              zs zs' x y (F₁.inst x) := {
+              prefixType := A
+              domain := B₁
+              codomain := F₁
+              piSort := uA
+              resultSortX := v
+              resultSortY := _
+              prefixX := htailSpineX
+              prefixY := htailSpineY
+              pi := hAeqPi
+              major := hxy
+              resultX := hchildType
+              resultY := hCodomain.symm }
+          have hchildLeaf : LR.PatternLeafSpine Γ₀ (LR Γ₀) CHead
+              (x :: zs) (y :: zs') (p :: rargs')
+              (F₁.inst x) ((g.lift (q + 1)).app p)
+                ((a₂.lift (q + 1)).app p) := {
+            majorX := x
+            recXs := zs
+            majorY := y
+            recYs := zs'
+            majorShape := p
+            recShapes := rargs'
+            majorTypeShape := a₁.lift (q + 1)
+            resultShape := g.lift (q + 1)
+            resultTypeShape := a₂.lift (q + 1)
+            args_eq := rfl
+            args'_eq := rfl
+            rargs_eq := rfl
+            out_eq := rfl
+            outTy_eq := rfl
+            pair := hchildPair
+            majorHasType := hp
+            resultType := htmK.1
+            majorType := hBK
+            majorRel := hv
+            aligned := hchildAligned
+            pi := hPiK }
+          simpa only [List.foldr_cons] using
+            ih x₀ y₀ hmem hchildLe hchildLeaf
+              hchildTerm ⟨v, hchildType⟩ hchildSpineX hchildSpineY
+              houtK hAK hy
+        rw [dif_pos hg]
+        refine (LRS.DefEq.lam_forallE
+          (M := xs.foldr (fun a f => f.app a) (.const c ls))
+          (N := ys.foldr (fun a f => f.app a) (.const c ls))
+          (A := A) (f := g) (hf := hg) (a₁ := a₁) (a₂ := a₂)
+          (LR Γ₀)).2 ?_
+        refine ⟨B₁, F₁, u, v, rA, hB.leftType,
+          (LR Γ₀).left_ty hValB, hF.leftType, hPi, ?_⟩
+        exact LR.constLamDefEq (hf := hg) (nArgs := q + 1) htm hlam₀
+          (fun {_ _ _ _ _} hp hxy hv hmem hx hy => ⟨
+            evalChild (Nat.max_eq_right (Nat.le_succ q))
+              hleaf.aligned.left hterm.hasType.1
+              hspineX hspineX hp hxy hv hmem hx hy,
+            evalChild (Nat.max_eq_right (Nat.le_succ q))
+              hleaf.aligned.right hterm.hasType.2
+              hspineY hspineY hp hxy hv hmem hx hy,
+            evalChild (Nat.max_eq_right (Nat.le_succ q))
+              hleaf.aligned hterm hspineX hspineY
+              hp hxy hv hmem hx hy⟩)
+      · rw [dif_neg hg]
+        exact (LR Γ₀).bot hout.isType
+    | ctor => exact (TShape.ctor_not_le_lam' hlam').elim
+    | indTy => exact (TShape.indTy_not_le_lam' hlam').elim
+  | @ctor semOut semArgs hcl hctor =>
+    have hlen : semArgs.length = rargs'.length := by
+      simpa using Lean4Lean.List.Forall₂.length_eq hargle
+    have hcl' : Params.classify c = some (.ctor rargs'.length) := hlen ▸ hcl
+    let K := max n n'
+    have hnK : n ≤ K := Nat.le_max_left ..
+    have hn'K : n' ≤ K := Nat.le_max_right ..
+    have hargsK := WShape.forall₂_liftT hnK hn'K hargle
+    have hctorT : (WShape.ctor' c semArgs.reverse).T ≤
+        (WShape.ctor' c rargs'.reverse).T := by
+      apply (TShape.LE.def (Nat.succ_le_succ hnK)
+        (Nat.succ_le_succ hn'K)).2
+      rw [WShape.lift_ctor' hnK, WShape.lift_ctor' hn'K,
+        List.map_reverse, List.map_reverse]
+      exact WShape.ctor'_le_ctor' (List.Forall₂.reverse.2 hargsK)
+    have hctor' := houtle.trans (hctor.trans hctorT)
+    cases hout.unfold with
+    | bot hm => exact (LR Γ₀).bot hm
+    | sort => exact (TShape.sort_not_le_ctor' hctor').elim
+    | forallE => exact (TShape.forallE_not_le_ctor' hctor').elim
+    | lam htm =>
+      unfold WShape.lam' at hctor' ⊢
+      split at hctor' <;> rename_i hnonzero
+      · exact (TShape.lam_not_le_ctor' hctor').elim
+      · simpa [hnonzero] using (LR Γ₀).bot hout.isType
+    | @ctor q c' fields hwf =>
+      have hIndHead : LRS.IndTyHead Γ₀ A := by
+        simpa only [LR_succ, LRS.TyDefEq.indTy_m] using hA.1
+      rw [LR_succ]
+      change LRS.IndDefEq Γ₀ (LR Γ₀)
+        (xs.foldr (fun a f => f.app a) (.const c ls))
+        (ys.foldr (fun a f => f.app a) (.const c ls)) A
+        (WShape.ctor c' fields hwf)
+      exact ⟨hIndHead, LRS.CtorDefEq.of_exact_ctor_spines
+        hleaf.args hleaf.aligned hleaf.aligned.symm hcl' rfl hhead hhead
+        hspineX hspineY hctor'⟩
+    | indTy => exact (TShape.indTy_not_le_ctor' hctor').elim
+  | @indTy semOut semArgs hcl hind =>
+    have hlen : semArgs.length = rargs'.length := by
+      simpa using Lean4Lean.List.Forall₂.length_eq hargle
+    have hcl' : Params.classify c = some (.indTy rargs'.length) := hlen ▸ hcl
+    have hind' := houtle.trans hind
+    cases hout.unfold with
+    | bot hm => exact (LR Γ₀).bot hm
+    | sort => exact (TShape.sort_not_le_indTy hind').elim
+    | forallE => exact (TShape.forallE_not_le_indTy hind').elim
+    | lam htm =>
+      unfold WShape.lam' at hind' ⊢
+      split at hind' <;> rename_i hnonzero
+      · exact (TShape.lam_not_le_indTy hind').elim
+      · simpa [hnonzero] using (LR Γ₀).bot hout.isType
+    | ctor => exact (TShape.ctor_not_le_indTy hind').elim
+    | indTy =>
+      rw [LR_succ]
+      change LRS.IndTyHead Γ₀
+          (xs.foldr (fun a f => f.app a) (.const c ls)) ∧
+        LRS.IndTyHead Γ₀
+          (ys.foldr (fun a f => f.app a) (.const c ls))
+      exact ⟨⟨c, ls, xs, hleaf.args.lengths.1.symm ▸ hcl', .rfl⟩,
+        ⟨c, ls, ys, hleaf.args.lengths.2.symm ▸ hcl', .rfl⟩⟩
+
+/-- Adequacy is closed under dependent application once the function,
+argument, and instantiated-result premises are available.  This isolates the
+shape join needed by application from the induction that supplies those
+three premises; in particular, proof-relevant fixed-head recursion can reuse
+the same handoff without rebuilding the shape argument. -/
+theorem LR.adequateApp
+    {Γ : List SExpr} {A B F F' X X' : SExpr} {v : SLevel}
+    {ρ : Valuation} {n : Nat} {m a : WShape n}
+    (Hf : IsDefEqStrong Γ F F' (A.forallE B))
+    (Ha : IsDefEqStrong Γ X X' A)
+    (HBa : IsDefEqStrong Γ (B.inst X) (B.inst X') (.sort v))
+    (hM : LE_Interp ρ m.T (.app F X))
+    (hA : LE_Interp ρ a.T (B.inst X))
+    (hmem : m.HasType a)
+    (ihf : ∀ {n'} {mf af : WShape n'},
+      LE_Interp ρ mf.T F → LE_Interp ρ af.T (.forallE A B) →
+      mf.HasType af → Adequate Γ₀ Γ ρ F F' (.forallE A B) mf af)
+    (iha : ∀ {n'} {ma aa : WShape n'},
+      LE_Interp ρ ma.T X → LE_Interp ρ aa.T A → ma.HasType aa →
+      Adequate Γ₀ Γ ρ X X' A ma aa)
+    (ihBa : ∀ {n'} {mb av : WShape n'},
+      LE_Interp ρ mb.T (B.inst X) → LE_Interp ρ av.T (.sort v) →
+      mb.HasType av →
+      Adequate Γ₀ Γ ρ (B.inst X) (B.inst X') (.sort v) mb av) :
+    Adequate Γ₀ Γ ρ (.app F X) (.app F' X') (B.inst X) m a := by
+  cases hM with
+  | bot => exact .bot hmem.isType
+  | @app _ nf_app f _ _ _ x hif hia le_m =>
+    suffices ∀ {F F' X X' σ σ'}, SubstWF Γ₀ σ σ' Γ ρ →
+        IsDefEqStrong Γ F F' (A.forallE B) →
+        IsDefEqStrong Γ X X' A →
+        IsDefEqStrong Γ (B.inst X) (B.inst X') (.sort v) →
+        LE_Interp ρ f.T F → LE_Interp ρ x.T X →
+        LE_Interp ρ a.T (B.inst X) →
+        (∀ {n'} {mf af : WShape n'}, LE_Interp ρ mf.T F →
+          LE_Interp ρ af.T (.forallE A B) → mf.HasType af →
+          Adequate Γ₀ Γ ρ F F' (.forallE A B) mf af) →
+        (∀ {n'} {ma aa : WShape n'}, LE_Interp ρ ma.T X →
+          LE_Interp ρ aa.T A → ma.HasType aa →
+          Adequate Γ₀ Γ ρ X X' A ma aa) →
+        (∀ {n'} {mb av : WShape n'}, LE_Interp ρ mb.T (B.inst X) →
+          LE_Interp ρ av.T (.sort v) → mb.HasType av →
+          Adequate Γ₀ Γ ρ (B.inst X) (B.inst X') (.sort v) mb av) →
+        (LR Γ₀).DefEq (.subst (.app F X) σ) (.subst (.app F' X') σ')
+          (.subst (B.inst X) σ) m a by
+      refine ⟨fun σ σ' W => ⟨?_, ?_⟩,
+        fun σ W => this W Hf Ha HBa hif hia hA ihf iha ihBa⟩
+      · refine this W (Hf.trans Hf.symm) (Ha.trans Ha.symm)
+          (HBa.trans HBa.symm) hif hia hA ?_ ?_ ?_
+        · exact fun hf hPi hmf => (ihf hf hPi hmf).left
+        · exact fun ha hA hma => (iha ha hA hma).left
+        · exact fun hB hv hmb => (ihBa hB hv hmb).left
+      · refine (LR _).conv ((LR _).symm_ty ?_) <| this W
+          (Hf.symm.trans Hf) (Ha.symm.trans Ha) (HBa.symm.trans HBa)
+          ((LE_Interp.sound Hf W.fits).1.1 hif)
+          ((LE_Interp.sound Ha W.fits).1.1 hia)
+          ((LE_Interp.sound HBa W.fits).1.1 hA)
+          (fun hf hPi hmf => ?_) (fun ha hA hma => ?_)
+          (fun hB hv hmb => ?_)
+        · have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+            (LE_Interp.sound HBa W.fits).2 hA |>.out
+          exact LR.toValTy le le' hmem.isType iv hmb
+            ((ihBa iB iv hmb).2 W.left)
+        · exact (ihf ((LE_Interp.sound Hf W.left.fits).1.2 hf)
+            hPi hmf).symm.left
+        · exact (iha ((LE_Interp.sound Ha W.left.fits).1.2 ha)
+            hA hma).symm.left
+        · exact (ihBa ((LE_Interp.sound HBa W.left.fits).1.2 hB)
+            hv hmb).symm.left
+    intro F F' X X' σ σ' W hF hX hBa hif hia hA ihf iha ihBa
+    have ⟨_, mf, _, le_nf, le_mf, hf', hPi, hmf⟩ :=
+      (LE_Interp.sound hF W.left.fits).2 hif |>.out
+    have Af := ihf hf' hPi hmf
+    by_cases hm0 : mf = .bot
+    · simp only [hm0] at le_mf hmf
+      refine (?_ : m = .bot) ▸ (LR _).bot hmem.isType
+      cases show f = .bot from TShape.le_bot.1 (le_mf.trans TShape.bot_le')
+      exact TShape.le_bot.1
+        ((WShape.bot_app ▸ le_m).trans TShape.bot_eqv.1)
+    cases hPi with
+    | bot => cases hm0 hmf.bot_r
+    | forallE haA hbA hd hiB le =>
+      cases hmf.unfold with
+      | bot => cases hm0 rfl
+      | lam hg =>
+        rename_i n₁ b₁' b₂' f' n₂ b₁ b₂ f
+        simp at le_nf
+        let k := max n (max n₁ n₂)
+        have hk := Nat.max_le.1 (Nat.le_refl k)
+        rw [Nat.max_le] at hk
+        have le_nf_k : nf_app ≤ k := Nat.le_trans le_nf hk.2.2
+        have hA' := hA.lift hk.1
+        have ⟨_, le_x', hx'_a₁, hgx2⟩ :=
+          WShape.HasDom.iff.1 hg.2.1 (x.lift _)
+        have hia' := (hia.lift le_nf).mono le_x'.T
+        have hax' := LE_Interp.forallE' haA hbA hd hiB
+          |>.mono le |>.forallE_inv.2 hia'
+        have hJ := TShape.Join.mk (hA.compat hax')
+        have ⟨hJ1, hJ2⟩ := (hJ _).1 .rfl
+        have hk' := Nat.max_le.2 ⟨hk.1, hk.2.2⟩
+        have hJ1' := (TShape.LE.def hk.1 hk').1 hJ1
+        have hJ2' := (TShape.LE.def hk.2.2 hk').1 hJ2
+        have hgx' := (WShape.HasTypeLam.iff.1 hg).2.2 _ hx'_a₁
+        have hJ_t := TShape.HasType.sort_r.2 hmem.isType
+          |>.join' hJ <| TShape.HasType.sort_r.2 hgx'.isType
+        have hmem_k := (WShape.HasType.lift hk.1).2 hmem
+        rw [subst_inst]
+        have hJ_t' := TShape.HasType.sort_r.1 <|
+          hJ_t.mono_l (TShape.lift_eqv hk').2 (TShape.lift_eqv hk').1
+        refine (LR.DefEq.lift hk.1 hmem).1 <|
+          (LR Γ₀).mono_r_2 hJ1' hmem_k hJ_t' ?_
+        have hgx'' := (WShape.HasType.lift hk.2.2).2 hgx'
+        refine (LR Γ₀).mono_l ?_
+          (.mono_r hJ1' hJ_t' hmem_k)
+          (.mono_r hJ2' hJ_t' hgx'') ?_
+        · exact (TShape.LE.def hk.1 hk.2.2).1 <| le_m.trans <|
+            (TShape.app_mono le_mf (TShape.lift_eqv le_nf).2).trans
+              (WShape.lam'_app ▸ hgx2.T)
+        refine (LR Γ₀).mono_r_1 hJ2' hgx''
+          (.mono_r hJ2' hJ_t' hgx'') ?_ ?_
+        · have ⟨_, _, _, le_j, le_j', hBj, hSj, hmj⟩ :=
+            (LE_Interp.sound hBa W.left.fits).2
+              (hA.join hJ hax') |>.out
+          exact (LR Γ₀).left_ty <|
+            (LR.TyDefEq.lift hk' (TShape.HasType.sort_r.1 hJ_t)).2 <|
+              subst_inst ▸ LR.toValTy le_j le_j'
+                (TShape.HasType.sort_r.1 hJ_t) hSj hmj
+                ((ihBa hBj hSj hmj).2 W.left)
+        · have hAf := (LR _).trans (Af.2 W.left) (Af.1 W).2
+          dsimp only [LR, LRS] at hAf
+          unfold WShape.lam' at hAf
+          split at hAf
+          · rw [LRS.DefEq.lam_forallE] at hAf
+            obtain ⟨_, _, _, _, red, _, _, _, _, valPi⟩ := hAf
+            cases WHNF.forallE.whRedS red
+            have le' := (TShape.LE.def
+              (Nat.succ_le_succ hk.2.2) (Nat.succ_le_succ hk.2.1)).1 le
+            simp only [WShape.T, WShape.lift_forallE hk.2.2,
+              WShape.lift_forallE hk.2.1,
+              WShape.forallE_le_forallE] at le'
+            have Aa := iha hia'
+              (haA.mono ((TShape.LE.def hk.2.2 hk.2.1).2 le'.1)) hx'_a₁
+            have harg := (LR _).trans (Aa.2 W.left) (Aa.1 W).2
+            exact (LR.DefEq.lift hk.2.2 hgx').2 <| (LR _).trans
+              (valPi.2 hx'_a₁ (hX.subst W.toSubstEq).hasType.1
+                <| (LR _).left harg)
+              (valPi.1 hx'_a₁ (hX.subst W.toSubstEq) harg).2
+          · refine (hm0 ?_).elim
+            unfold WShape.lam'
+            simp_all
+      | _ =>
+        refine have le₂ := Nat.succ_le_succ (Nat.le_max_right ..)
+          have hbad := (TShape.LE.def
+            (Nat.le_succ_of_le (Nat.le_max_left ..)) le₂).1 le
+          ?_
+        simp only [WShape.lift_sort, WShape.LE.def,
+          WShape.lift_val le₂] at hbad
+        cases hbad
+
+/-- Self-adequacy is closed under dependent product formation once the
+domain and codomain self-adequacy premises are available.  The proof uses
+the relational substitution itself below the binder, so retained-tree
+recursion can consume strictly shallower domain and codomain packages without
+re-entering the full adequacy induction. -/
+theorem LR.adequateForallESelf
+    {Γ : List SExpr} {A body : SExpr} {u v : SLevel}
+    {ρ : Valuation} {n : Nat} {m a : WShape n}
+    (HA : IsDefEqStrong Γ A A (.sort u))
+    (HBody : IsDefEqStrong (A :: Γ) body body (.sort v))
+    (hM : LE_Interp ρ m.T (.forallE A body))
+    (hA : LE_Interp ρ a.T (.sort (.imax u v)))
+    (hmem : m.HasType a)
+    (ihA : ∀ {ρ n} {ma aa : WShape n},
+      LE_Interp ρ ma.T A → LE_Interp ρ aa.T (.sort u) →
+      ma.HasType aa → Adequate Γ₀ Γ ρ A A (.sort u) ma aa)
+    (ihBody : ∀ {ρ n} {mb ab : WShape n},
+      LE_Interp ρ mb.T body → LE_Interp ρ ab.T (.sort v) →
+      mb.HasType ab →
+      Adequate Γ₀ (A :: Γ) ρ body body (.sort v) mb ab) :
+    Adequate Γ₀ Γ ρ (.forallE A body) (.forallE A body)
+      (.sort (.imax u v)) m a := by
+  cases hmem.unfold with
+  | bot hm =>
+    cases hm.unfold with
+    | forallE =>
+      let .sort h := hA
+      cases (TShape.LE.lift_r (by simp [TShape.sort])).1 h
+    | _ => exact .bot hmem.isType
+  | sort =>
+    cases n <;>
+      have .forallE _ _ _ _ h := hM <;>
+      cases TShape.sort_not_le_forallE h
+  | @lam _ f₀ =>
+    revert hM
+    unfold WShape.lam'
+    split <;> [skip; exact fun _ => .bot hmem.isType]
+    intro | .forallE _ _ _ _ h => cases TShape.lam_not_le_forallE h
+  | ctor =>
+    have .forallE _ _ _ _ h := hM
+    cases TShape.ctor_not_le_forallE h
+  | indTy =>
+    have .forallE _ _ _ _ h := hM
+    cases TShape.indTy_not_le_forallE h
+  | @forallE k a₂ a₁ r aty =>
+    have aty := WShape.HasTypePi.iff.1 aty
+    have hA1 := hM.forallE_inv.1
+    have cons := Adequate.cons ihA HA
+    refine .refl fun σ σ' W => ?_
+    have ⟨_, a', _, le_n, le_a, hA', hSort, hmem'⟩ :=
+      (LE_Interp.sound HA W.left.fits).2 hA1 |>.out
+    have HAσ := (HA.substCongr W.toSubstEq).1
+    have S' := W.toSubstEq.lift HA.defeq.hasType.1
+    refine ⟨A.subst σ, body.subst σ.lift,
+      A.subst σ', body.subst σ'.lift, u, v,
+      .rfl, .rfl, .single HAσ,
+      .single (HBody.substCongr S').1, ?_, ?_⟩
+    · exact LR.toValTy le_n le_a aty.1.isType hSort hmem'
+        ((ihA hA' hSort hmem').1 W).1
+    simp only [LRS.PiDefEq]
+    constructor
+    · intro x x' p hp ha hv
+      have hB := hM.forallE_inv'.2 p
+      have WL := cons hp hA1 ha hv W.left
+      have ⟨_, _, _, leL, leL', iBL, ivL, hmbL⟩ :=
+        (LE_Interp.sound HBody WL.fits).2 hB |>.out
+      have semL : (LR Γ₀).TyDefEq
+          ((body.subst σ.lift).inst x) ((body.subst σ.lift).inst x')
+          (a₂.app p) := by
+        simpa [inst_lift_cons] using
+          LR.toValTy leL leL' (aty.2 _ hp).toType ivL hmbL
+            ((ihBody iBL ivL hmbL).1 WL).1
+      have valA := LR.toValTy le_n le_a aty.1.isType hSort hmem'
+        ((ihA hA' hSort hmem').1 W).1
+      have WR := cons hp hA1 (HAσ.defeqDF ha) ((LR Γ₀).conv valA hv)
+        W.symm.left
+      have ⟨_, _, _, leR, leR', iBR, ivR, hmbR⟩ :=
+        (LE_Interp.sound HBody WR.fits).2 hB |>.out
+      have semR : (LR Γ₀).TyDefEq
+          ((body.subst σ'.lift).inst x) ((body.subst σ'.lift).inst x')
+          (a₂.app p) := by
+        simpa [inst_lift_cons] using
+          LR.toValTy leR leR' (aty.2 _ hp).toType ivR hmbR
+            ((ihBody iBR ivR hmbR).1 WR).1
+      have rawL : Γ₀ ⊢
+          (body.subst σ.lift).inst x ≡
+            (body.subst σ.lift).inst x' : .sort v := by
+        simpa only [inst_lift_cons, SExpr.subst] using
+          (HBody.substCongr WL.toSubstEq).1
+      have rawR : Γ₀ ⊢
+          (body.subst σ'.lift).inst x ≡
+            (body.subst σ'.lift).inst x' : .sort v := by
+        simpa only [inst_lift_cons, SExpr.subst] using
+          (HBody.substCongr WR.toSubstEq).1
+      exact ⟨semL, semR, ⟨v, rawL⟩, ⟨v, rawR⟩⟩
+    · intro x p hp ha hv
+      have hB := hM.forallE_inv'.2 p
+      have WX := cons hp hA1 ha.hasType.1 ((LR Γ₀).left hv) W
+      have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+        (LE_Interp.sound HBody WX.fits).2 hB |>.out
+      have hout : (LR Γ₀).TyDefEq
+          ((body.subst σ.lift).inst x) ((body.subst σ'.lift).inst x)
+          (a₂.app p) := by
+        simpa [inst_lift_cons] using
+          LR.toValTy le le' (aty.2 _ hp).toType iv hmb
+            ((ihBody iB iv hmb).1 WX).1
+      exact cast (by congr 1) hout
+
+/-- Adequacy is closed under a displayed-type conversion once adequacy of
+the type equality and of the term at its original type are available.  The
+statement makes the one heterogeneous callback required by the retained
+self-validity recursion explicit. -/
+theorem LR.adequateDefeq
+    {Γ : List SExpr} {A B e : SExpr} {u : SLevel}
+    {ρ : Valuation} {n : Nat} {m b : WShape n}
+    (Hty : IsDefEqStrong Γ A B (.sort u))
+    (hM : LE_Interp ρ m.T e)
+    (hB : LE_Interp ρ b.T B)
+    (hmem : m.HasType b)
+    (ihTy : ∀ {n'} {ma sa : WShape n'},
+      LE_Interp ρ ma.T A → LE_Interp ρ sa.T (.sort u) → ma.HasType sa →
+      Adequate Γ₀ Γ ρ A B (.sort u) ma sa)
+    (ihE : ∀ {n'} {me ae : WShape n'},
+      LE_Interp ρ me.T e → LE_Interp ρ ae.T A → me.HasType ae →
+      Adequate Γ₀ Γ ρ e e A me ae) :
+    Adequate Γ₀ Γ ρ e e B m b := by
+  have tyConv {σ} (W : SubstWF Γ₀ σ σ Γ ρ) :=
+    have hA := (LE_Interp.sound Hty W.fits).1.2 hB
+    have ⟨_, a', _, le_n, le_a, hA', hSort, hmem'⟩ :=
+      (LE_Interp.sound Hty W.fits).2 hA |>.out
+    LR.toValTy le_n le_a hmem.isType hSort hmem'
+      ((ihTy hA' hSort hmem').2 W)
+  refine ⟨fun σ σ' W => ?_, fun σ W => ?_⟩ <;>
+    have hA := (LE_Interp.sound Hty W.left.fits).1.2 hB
+  · exact ⟨(LR Γ₀).conv (tyConv W.left) ((ihE hM hA hmem).1 W).1,
+           (LR Γ₀).conv (tyConv W.left) ((ihE hM hA hmem).1 W).2⟩
+  · exact (LR Γ₀).conv (tyConv W) ((ihE hM hA hmem).2 W)
+
+/-- Self-validity is closed under a displayed-type conversion using the
+joint adequacy/uniqueness tower.
+
+Unlike `adequateDefeq`, this form does not ask the recursive consumer for a
+heterogeneous adequacy proof of `A ≡ B`.  It asks only for self-validity of
+`A`, `B`, and `e : A`.  At every relational substitution,
+`TyDefEq.of_defeq_of_jointBuilder` combines the substituted raw type equality
+with the two self observations, after which ordinary logical conversion
+finishes the term.  This is the conversion algebra needed by the retained
+fixed-head recursion. -/
+theorem LR.adequateDefeqSelf_of_stratifiedInversion
+    {Γ : List SExpr} {A B e : SExpr} {u : SLevel}
+    {ρ : Valuation} {n : Nat} {m b : WShape n}
+    (inv : JointStratifiedInversion) (hΓ₀ : Ctx.WF Γ₀)
+    (Hty : IsDefEqStrong Γ A B (.sort u))
+    (hM : LE_Interp ρ m.T e)
+    (hB : LE_Interp ρ b.T B)
+    (hmem : m.HasType b)
+    (ihA : ∀ {n'} {ma sa : WShape n'},
+      LE_Interp ρ ma.T A → LE_Interp ρ sa.T (.sort u) → ma.HasType sa →
+      Adequate Γ₀ Γ ρ A A (.sort u) ma sa)
+    (ihB : ∀ {n'} {mb sb : WShape n'},
+      LE_Interp ρ mb.T B → LE_Interp ρ sb.T (.sort u) → mb.HasType sb →
+      Adequate Γ₀ Γ ρ B B (.sort u) mb sb)
+    (ihE : ∀ {n'} {me ae : WShape n'},
+      LE_Interp ρ me.T e → LE_Interp ρ ae.T A → me.HasType ae →
+      Adequate Γ₀ Γ ρ e e A me ae) :
+    Adequate Γ₀ Γ ρ e e B m b := by
+  have tyConv {σ} (W : SubstWF Γ₀ σ σ Γ ρ) :=
+    have hA := (LE_Interp.sound Hty W.fits).1.2 hB
+    have ⟨_, a', s', le_n, le_a, hA', hSort, hmem'⟩ :=
+      (LE_Interp.sound Hty W.fits).2 hA |>.out
+    have hB' := (LE_Interp.sound Hty W.fits).1.1 hA'
+    have hAA : (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ) a' :=
+      (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
+        (.mono_r hSort.le_sort' .sort hmem') .sort
+        ((ihA hA' hSort hmem').2 W)
+    have hBB : (LR Γ₀).TyDefEq (B.subst σ) (B.subst σ) a' :=
+      (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
+        (.mono_r hSort.le_sort' .sort hmem') .sort
+        ((ihB hB' hSort hmem').2 W)
+    have hAB : Γ₀ ⊢ A.subst σ ≡ B.subst σ : .sort u := by
+      simpa only [SExpr.subst] using Hty.subst W.toSubstEq
+    have hABsem : (LR Γ₀).TyDefEq (A.subst σ) (B.subst σ) a' :=
+      LR.TyDefEq.of_defeq_of_stratifiedInversion inv hΓ₀ hAB hAA hBB
+    have ha'Type : a'.HasType .type :=
+      (WShape.HasType.mono_r hSort.le_sort' .sort hmem').toType
+    (LR.TyDefEq.lift le_n hmem.isType).1 <|
+      (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
+        (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 hmem.isType)
+        ha'Type hABsem
+  refine ⟨fun σ σ' W => ?_, fun σ W => ?_⟩ <;>
+    have hA := (LE_Interp.sound Hty W.left.fits).1.2 hB
+  · exact ⟨(LR Γ₀).conv (tyConv W.left) ((ihE hM hA hmem).1 W).1,
+           (LR Γ₀).conv (tyConv W.left) ((ihE hM hA hmem).1 W).2⟩
+  · exact (LR Γ₀).conv (tyConv W) ((ihE hM hA hmem).2 W)
+
+/-- Compatibility wrapper for callers that already carry the completed
+joint builder. -/
+theorem LR.adequateDefeqSelf_of_jointBuilder
+    {Γ : List SExpr} {A B e : SExpr} {u : SLevel}
+    {ρ : Valuation} {n : Nat} {m b : WShape n}
+    (J : LR.JointBuilder) (hΓ₀ : Ctx.WF Γ₀)
+    (Hty : IsDefEqStrong Γ A B (.sort u))
+    (hM : LE_Interp ρ m.T e)
+    (hB : LE_Interp ρ b.T B)
+    (hmem : m.HasType b)
+    (ihA : ∀ {n'} {ma sa : WShape n'},
+      LE_Interp ρ ma.T A → LE_Interp ρ sa.T (.sort u) → ma.HasType sa →
+      Adequate Γ₀ Γ ρ A A (.sort u) ma sa)
+    (ihB : ∀ {n'} {mb sb : WShape n'},
+      LE_Interp ρ mb.T B → LE_Interp ρ sb.T (.sort u) → mb.HasType sb →
+      Adequate Γ₀ Γ ρ B B (.sort u) mb sb)
+    (ihE : ∀ {n'} {me ae : WShape n'},
+      LE_Interp ρ me.T e → LE_Interp ρ ae.T A → me.HasType ae →
+      Adequate Γ₀ Γ ρ e e A me ae) :
+    Adequate Γ₀ Γ ρ e e B m b :=
+  LR.adequateDefeqSelf_of_stratifiedInversion
+    J.stratifiedInversion hΓ₀ Hty hM hB hmem ihA ihB ihE
+
+/-- Depth-indexed self-adequacy for every lower observation of one exact
+interpretation witness.  Lowering preserves the proof-relevant evaluator
+tree, which is exactly the variance needed by a generated RHS
+`ShapeSpine`: its fixed head is observed below the root selected by the
+constant evaluator. -/
+def LR.SelfAdequateAt (Γ₀ : List SExpr)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X)
+    (depth : Nat) : Prop :=
+  ∀ {n : Nat} {mx bx : WShape n} {Δ : List SExpr} {core : Bool}
+      {B : SExpr},
+    mx.T ≤ root →
+    HasTypeStratifiedS Δ X B core depth →
+    mx.HasType bx →
+    LE_Interp.Witness ρ bx.T B →
+    LR.Adequate Γ₀ Δ ρ X X B mx bx
+
+/-- Consume a synchronized lower fixed-head endpoint at one common shape
+level.
+
+The ordered telescope may construct its term and type endpoints at different
+`TShape` levels.  Both are lifted along equivalences to their maximum level
+before invoking `SelfAdequateAt`; the registered-type witness is transported
+only by root lowering.  No typing fact is projected from an upper term
+observation to a lower one. -/
+theorem LR.SelfAdequateAt.of_typedLowerWitness
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.SelfAdequateAt Γ₀ hX depth)
+    {Δ : List SExpr} {B : SExpr} {core : Bool}
+    {head : TShape}
+    (hhead : head ≤ root)
+    (hstrat : HasTypeStratifiedS Δ X B core depth)
+    (endpoint : ∃ headElem headTy : TShape,
+      headElem ≤ head ∧ headElem.HasType headTy ∧
+        Nonempty (LE_Interp.Witness ρ headTy B)) :
+    ∃ (n : Nat) (mx bx : WShape n),
+      mx.T ≤ head ∧ mx.HasType bx ∧
+        LR.Adequate Γ₀ Δ ρ X X B mx bx := by
+  obtain ⟨headElem, headTy, helem, htyped, ⟨hB⟩⟩ := endpoint
+  let n := max headElem.1 headTy.1
+  have hElemLevel : headElem.1 ≤ n := Nat.le_max_left _ _
+  have hTyLevel : headTy.1 ≤ n := Nat.le_max_right _ _
+  let mx : WShape n := headElem.2.lift n
+  let bx : WShape n := headTy.2.lift n
+  have hmxElem : mx.T ≤ headElem := by
+    exact (TShape.lift_eqv hElemLevel).1
+  have hbxTy : bx.T ≤ headTy := by
+    exact (TShape.lift_eqv hTyLevel).1
+  have hmxbx : mx.HasType bx := by
+    exact (TShape.HasType.def hElemLevel hTyLevel).1 htyped
+  refine ⟨n, mx, bx, hmxElem.trans helem, hmxbx, ?_⟩
+  exact H ((hmxElem.trans helem).trans hhead) hstrat hmxbx
+    (hB.mono hbxTy)
+
+/-- The ordered telescope is a complete producer for the synchronized
+endpoint consumed by `SelfAdequateAt.of_typedLowerWitness`. -/
+theorem LR.SelfAdequateAt.of_typedTelescope
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.SelfAdequateAt Γ₀ hX depth)
+    {Δ : List SExpr} {B : SExpr} {core : Bool}
+    {p : Pattern} {mcap : p.Path → TShape}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (hhead : head ≤ root)
+    (hstrat : HasTypeStratifiedS Δ X B core depth)
+    (telescope : LE_Interp.RHS.ShapeSpine.TypedTelescope
+      mcap spine headTy outTy)
+    (hTy : LE_Interp.Witness ρ headTy B) :
+    ∃ (n : Nat) (mx bx : WShape n),
+      mx.T ≤ head ∧ mx.HasType bx ∧
+        LR.Adequate Γ₀ Δ ρ X X B mx bx :=
+  H.of_typedLowerWitness hhead hstrat
+    (telescope.lowerHead.withWitness hTy)
+
+/-- Consume the full fixed-head telescope certificate at the self-adequacy
+boundary.  The capture payload is retained for the subsequent application
+fold, while this projection uses only its synchronized lower endpoint and
+registered-type witness. -/
+theorem LR.SelfAdequateAt.of_fixedHeadTelescope
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.SelfAdequateAt Γ₀ hX depth)
+    {Δ : List SExpr} {B : SExpr} {core : Bool}
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {head out headTy outTy : TShape} {paths : List p.Path}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out}
+    (hhead : head ≤ root)
+    (hstrat : HasTypeStratifiedS Δ X B core depth)
+    (telescope : LR.FixedHeadTelescope
+      (headTy := headTy) (outTy := outTy)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy B) :
+    ∃ (n : Nat) (headElem headElemTy : WShape n),
+      headElem.T ≤ head ∧ headElem.HasType headElemTy ∧
+        LR.Adequate Γ₀ Δ ρ X X B headElem headElemTy :=
+  H.of_typedLowerWitness hhead hstrat
+    (telescope.withWitness hTy)
+
+/-- The `headSelf` callback of the fixed-head application fold, produced
+without any global adequacy package at the rung's own depth.
+
+This is the depth-refined replacement for `LR.AdequacyAtDepth.closedHeadSelf`.
+The term half is the consumer's own `LR.SelfAdequateAt` at the *same* witness
+and the *same* depth — the coherent algebra already holds it, so nothing is
+manufactured; the type half is the isolated `LR.FixedHeadTypeValidStep`,
+whose real demand sits at `depth - 1`.  Both endpoints are the literal ones
+the packed telescope selected: no shape or index is re-chosen here. -/
+theorem LR.SelfAdequateAt.closedHeadSelf
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.SelfAdequateAt Γ₀ hX depth)
+    (typeValid : LR.FixedHeadTypeValidStep Γ₀ depth)
+    {Δ : List SExpr} {σ σ' : Subst} {headType : SExpr} {core : Bool}
+    {head : TShape}
+    (hhead : head ≤ root)
+    (hstrat : HasTypeStratifiedS Δ X headType core depth)
+    (W : LR.SubstWF Γ₀ σ σ' Δ ρ)
+    (hXClosed : X.ClosedN) (hTypeClosed : headType.ClosedN)
+    {n : Nat} {headElem headElemTy : WShape n}
+    (helem : headElem.T ≤ head)
+    (htyped : headElem.HasType headElemTy)
+    (hTy : LE_Interp.Witness ρ headElemTy.T headType) :
+    (LR Γ₀).DefEq X X headType headElem headElemTy ∧
+      (LR Γ₀).TyDefEq headType headType headElemTy := by
+  have hrel := ((H (helem.trans hhead) hstrat htyped hTy).1 W).1
+  rw [hXClosed.subst_eq .zero, hXClosed.subst_eq .zero,
+    hTypeClosed.subst_eq .zero] at hrel
+  exact ⟨hrel, typeValid W hstrat hTypeClosed htyped hTy⟩
+
+/-- Finish the packed fixed-head application from the consumer's own
+self-adequacy instead of a same-rung `LR.AdequacyAtDepth`.
+
+Compare `LR.FixedHeadTelescope.toApplicationWithAdequacyAtDepth`, which
+demands `LR.AdequacyAtDepth Γ₀ depth`.  That input is replaced here by two
+strictly weaker ones that the coherent algebra can actually meet: the
+self-adequacy result at this witness and depth, and the isolated type rung
+`LR.FixedHeadTypeValidStep Γ₀ depth`.  Everything else is unchanged, so this
+is a drop-in strengthening of the producer, not a new route. -/
+theorem LR.FixedHeadTelescope.toApplicationWithSelfAdequacy
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    {headType resultType : SExpr}
+    {hX : LE_Interp.Witness ρ root X} {depth : Nat}
+    (H : LR.FixedHeadTelescope
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy headType)
+    (houtNonbot : ¬out.T ≤ TShape.bot)
+    (raw : SExpr.PathSpineWF Γ₀ mx captureType
+      headType paths resultType)
+    (resultRel : (LR Γ₀).TyDefEq
+      resultType resultType outTy)
+    (convert : LR.FixedHeadConvertStep Γ₀)
+    (hself : LR.SelfAdequateAt Γ₀ hX depth)
+    (typeValid : LR.FixedHeadTypeValidStep Γ₀ depth)
+    (hhead : head ≤ root)
+    {Δ : List SExpr} {σ σ' : Subst} {core : Bool}
+    (hstrat : HasTypeStratifiedS Δ X headType core depth)
+    (W : LR.SubstWF Γ₀ σ σ' Δ ρ)
+    (hXClosed : X.ClosedN) (hTypeClosed : headType.ClosedN) :
+    LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy := by
+  apply H.toApplicationWith hTy houtNonbot raw resultRel convert
+  intro headLevel headElem headElemTy helem htyped hheadTy
+  exact hself.closedHeadSelf typeValid hhead hstrat W hXClosed hTypeClosed
+    helem htyped hheadTy
+
+/-- The same producer adapter for the monotone telescope. -/
+theorem LR.FixedHeadTelescopeLE.toApplicationWithSelfAdequacy
+    {p : Pattern} {mcap : p.Path → TShape}
+    {mx my captureType : p.Path → SExpr}
+    {paths : List p.Path} {head headTy : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {spine : LE_Interp.RHS.ShapeSpine mcap head paths out.T}
+    {headType resultType : SExpr}
+    {hX : LE_Interp.Witness ρ root X} {depth : Nat}
+    (H : LR.FixedHeadTelescopeLE
+      (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType spine)
+    (hTy : LE_Interp.Witness ρ headTy headType)
+    (houtNonbot : ¬out.T ≤ TShape.bot)
+    (raw : SExpr.PathSpineWF Γ₀ mx captureType
+      headType paths resultType)
+    (resultRel : (LR Γ₀).TyDefEq
+      resultType resultType outTy)
+    (convert : LR.FixedHeadConvertStep Γ₀)
+    (hself : LR.SelfAdequateAt Γ₀ hX depth)
+    (typeValid : LR.FixedHeadTypeValidStep Γ₀ depth)
+    (hhead : head ≤ root)
+    {Δ : List SExpr} {σ σ' : Subst} {core : Bool}
+    (hstrat : HasTypeStratifiedS Δ X headType core depth)
+    (W : LR.SubstWF Γ₀ σ σ' Δ ρ)
+    (hXClosed : X.ClosedN) (hTypeClosed : headType.ClosedN) :
+    LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy := by
+  apply H.toApplicationWith hTy houtNonbot raw resultRel convert
+  intro headLevel headElem headElemTy helem htyped hheadTy
+  exact hself.closedHeadSelf typeValid hhead hstrat W hXClosed hTypeClosed
+    helem htyped hheadTy
+
+/-- Consume a completed fixed-head application package.
+
+The exact fixed-head term relation is stored by the producer together with
+the lower term/type endpoint and the exposed application chain.  Consumption
+therefore performs no second adequacy call and cannot reselect a different
+head witness or typing derivation. -/
+theorem LR.FixedHeadApplication.apply
+    {hX : LE_Interp.Witness rho root X}
+    (H : LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType paths headType resultType head out outTy)
+    : (LR Γ₀).DefEq
+      (paths.foldl (fun f path => f.app (mx path)) X)
+      (paths.foldl (fun f path => f.app (my path)) X)
+      resultType out outTy := by
+  obtain ⟨headLevel, headElem, headElemTy, helem, htyped,
+    ⟨_hType⟩, hheadRel, chain⟩ := H
+  exact chain.apply hheadRel
+
+/-- Rewrite the generic fixed-head fold to the generated RHS syntax stored
+by an iota descriptor. -/
+theorem LR.FixedHeadApplication.applyRule
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r}
+    {mcap : (RecursorIotaPattern rec major ctor arity).Path → TShape}
+    {mx my captureType :
+      (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {resultType : SExpr} {head : TShape}
+    {outLevel : Nat} {out outTy : WShape outLevel}
+    {hX : LE_Interp.Witness rho root
+      (SExpr.mkInst recLs rule.df.rhs)}
+    (H : LR.FixedHeadApplication Γ₀ hX depth
+      mcap mx my captureType rule.capturePaths
+      (SExpr.mkInst recLs rule.df.type) resultType head out outTy)
+    :
+    (LR Γ₀).DefEq
+      (r.1.applyS recLs mx) (r.1.applyS recLs my)
+      resultType out outTy := by
+  rw [← rule.rhsApply recLs mx, ← rule.rhsApply recLs my]
+  simpa only [List.foldl_map] using H.apply
+
+/-- Exact-root worker used to prove the downward-closed public contract. -/
+private def LR.SelfAdequateExactAt (Γ₀ : List SExpr)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X)
+    (depth : Nat) : Prop :=
+  ∀ {n : Nat} {mx bx : WShape n} {Δ : List SExpr} {core : Bool}
+      {B : SExpr},
+    root = mx.T →
+    HasTypeStratifiedS Δ X B core depth →
+    mx.HasType bx →
+    LE_Interp.Witness ρ bx.T B →
+    LR.Adequate Γ₀ Δ ρ X X B mx bx
+
+/-- The consumer result at one exact syntax depth. -/
+def LR.CoherentRetainedAt (Γ₀ : List SExpr)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X)
+    (depth : Nat) : Prop :=
+  LR.SelfAdequateAt Γ₀ hX depth ∧
+    LR.FixedHeadResultAt Γ₀ hX depth
+
+/-- The depth-polymorphic consumer attached to one exact evaluator witness.
+
+This is not itself used as an undifferentiated tree predicate.  Semantic `R`
+descent may legitimately restart the registered RHS at a larger syntax
+depth.  The coherent step below instead distinguishes all-depth results
+attached to genuine evaluator children from exact-depth results attached
+only after a strict Nat decrease. -/
+def LR.CoherentRetainedResult (Γ₀ : List SExpr)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) : Prop :=
+  ∀ depth, LR.CoherentRetainedAt Γ₀ hX depth
+
+/-- Inspectable evidence attached to an actual evaluator edge.  Genuine
+children carry the all-depth result; a tree rebuilt after a strict Nat
+decrease carries only the exact-depth result. -/
+abbrev LR.CoherentSeedAt (Γ₀ : List SExpr) (depth : Nat)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) : Prop :=
+  LE_Interp.Witness.NatSeed
+    (fun hX depth => LR.CoherentRetainedAt Γ₀ hX depth) depth hX
+
+/-- A recursive RHS witness together with exactly the typing evidence needed
+to consume it as a fixed head.
+
+Genuine evaluator children carry the all-depth result and need no chosen
+typing certificate.  A rebuilt child remains local and must carry the
+registered RHS typing at that same local depth.  Packaging the two branches
+here prevents a later proof-irrelevant witness selection from pairing one
+edge's result with another edge's depth certificate. -/
+def LR.CoherentRhsSeedAt (Γ₀ Δ : List SExpr) (depth : Nat)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) (B : SExpr) : Prop :=
+  LR.CoherentRetainedResult Γ₀ hX ∨
+    (LR.CoherentRetainedAt Γ₀ hX depth ∧
+      HasTypeStratifiedS Δ X B true depth)
+
+/-- Action-indexed evidence retained on the literal fixed RHS edge created
+by focused reverse conversion.
+
+The semantic preimage owns the exact applied-RHS and peeled-head
+stratifications together with the selected head witness and shape spine.
+`edge` identifies the concrete root lowering stored by the rebuilt constant,
+while `realizes` prevents the certificate from being attached to a different
+witness with the same public syntax and shape indices. -/
+structure LR.FocusedRhsOriginAt (Γ₀ : List SExpr) (depth : Nat)
+    {rho root X} (hX : LE_Interp.Witness rho root X) where
+  recName : Name
+  ctorName : Name
+  major : Nat
+  arity : Nat
+  r : (RecursorIotaPattern recName major ctorName arity).RHS ×
+    (RecursorIotaPattern recName major ctorName arity).Check
+  rule : Pattern.IotaRule r
+  Gamma : List SExpr
+  e : SExpr
+  ls : List SLevel
+  capture : (RecursorIotaPattern recName major ctorName arity).Path → SExpr
+  A : SExpr
+  action : Pattern.Action Gamma r e ls capture A
+  rhsRoot : TShape
+  rhsWitness : LE_Interp.Witness rho rhsRoot
+    (r.1.applyS ls capture)
+  rhsDepth : Nat
+  preimage : rule.FocusedActionPreimage action rhsWitness rhsDepth
+  edge : preimage.headWitness.LowerEdge root X
+  realizes : hX = edge.realize
+  retained : LR.CoherentRetainedAt Γ₀ hX depth
+
+/-- An action-indexed focused origin with its original proof-relevant edge
+hidden, but its registered-head syntax retained as the index.
+
+This is the conversion-path payload used when a later computational equality
+must select a fresh endpoint witness.  The fresh edge receives its own local
+retained result; this trace contributes only the earlier focused action and
+can be replayed only at the same fixed-head syntax. -/
+def LR.FocusedRhsTraceAt (Γ₀ : List SExpr) (depth : Nat)
+    (X : SExpr) : Prop :=
+  ∃ (rho : Valuation) (root : TShape),
+    ∃ hX : LE_Interp.Witness rho root X,
+      Nonempty (LR.FocusedRhsOriginAt Γ₀ depth hX)
+
+/-- A conversion suffix carries the complete set of focused origins visible
+in its source tree, rather than choosing one origin prematurely.
+
+The predicate field records which registered-head syntaxes occur and
+`replay` recovers the corresponding action-indexed certificate.  Keeping the
+whole set is essential when one converted tree contains several generated
+rules: a later fixed-head consumer, not the transport, is the first point
+that knows which rule it needs. -/
+structure LR.FocusedRhsTraceBundleAt
+    (Γ₀ : List SExpr) (depth : Nat) where
+  contains : SExpr → Prop
+  replay : ∀ {X}, contains X → LR.FocusedRhsTraceAt Γ₀ depth X
+
+/-- Inspectable seed used only inside retained semantic typing.
+
+Ordinary transports retain the old Nat provenance.  A focused reverse iota
+edge additionally carries its action-indexed typing origin.  Keeping this
+wrapper outside `CoherentSeedAt` means the outer semantic/Nat recursion still
+grants genuine children exactly the same hypotheses as before. -/
+inductive LR.CoherentSemanticSeedAt (Γ₀ : List SExpr) (depth : Nat) :
+    {rho : Valuation} → {root : TShape} → {X : SExpr} →
+      LE_Interp.Witness rho root X → Prop where
+  | ordinary {hX : LE_Interp.Witness rho root X} :
+      LR.CoherentSeedAt Γ₀ depth hX →
+      LR.CoherentSemanticSeedAt Γ₀ depth hX
+  | focused {hX : LE_Interp.Witness rho root X} :
+      Nonempty (LR.FocusedRhsOriginAt Γ₀ depth hX) →
+      LR.CoherentSemanticSeedAt Γ₀ depth hX
+  | carried {hX : LE_Interp.Witness rho root X} :
+      LR.FocusedRhsTraceBundleAt Γ₀ depth →
+      LR.CoherentRetainedAt Γ₀ hX depth →
+      LR.CoherentSemanticSeedAt Γ₀ depth hX
+  | replayed {hX : LE_Interp.Witness rho root X} :
+      (bundle : LR.FocusedRhsTraceBundleAt Γ₀ depth) →
+      bundle.contains X →
+      LR.CoherentRetainedAt Γ₀ hX depth →
+      LR.CoherentSemanticSeedAt Γ₀ depth hX
+
+/-- Transportable recursive-edge provenance used inside retained semantic
+typing.  The outer consumer algebra receives `CoherentSeedAt`, not this free
+closure. -/
+abbrev LR.CoherentProvenanceAt (Γ₀ : List SExpr) (depth : Nat)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) : Prop :=
+  LE_Interp.Witness.TransportClosure
+    (LR.CoherentSemanticSeedAt Γ₀ depth) hX
+
+/-- Inject the all-depth result of a genuine evaluator child. -/
+theorem LR.CoherentSeedAt.all
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedResult Γ₀ hX) :
+    LR.CoherentSeedAt Γ₀ depth hX :=
+  .inl H
+
+/-- Inject a result justified only at this exact smaller syntax depth. -/
+theorem LR.CoherentSeedAt.local
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedAt Γ₀ hX depth) :
+    LR.CoherentSeedAt Γ₀ depth hX :=
+  .inr H
+
+/-- Consume either form of inspectable recursive-edge evidence at its stated
+depth. -/
+theorem LR.CoherentSeedAt.result
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentSeedAt Γ₀ depth hX) :
+    LR.CoherentRetainedAt Γ₀ hX depth :=
+  H.elim (fun H => H depth) id
+
+/-- Inject the structurally recursive, all-depth result of a genuine
+evaluator child into depth-local provenance. -/
+theorem LR.CoherentProvenanceAt.all
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedResult Γ₀ hX) :
+    LR.CoherentProvenanceAt Γ₀ depth hX :=
+  .base (.ordinary (.inl H))
+
+/-- Inject a result justified only at the current, strictly smaller syntax
+depth.  This constructor deliberately does not manufacture an all-depth
+recursive hypothesis. -/
+theorem LR.CoherentProvenanceAt.local
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedAt Γ₀ hX depth) :
+    LR.CoherentProvenanceAt Γ₀ depth hX :=
+  .base (.ordinary (.inr H))
+
+/-- Every transient semantic seed still supplies the retained consumer fact
+at the current guarded depth.  Focused origins expose the same local result
+without forgetting their action-indexed certificate. -/
+theorem LR.CoherentSemanticSeedAt.result
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentSemanticSeedAt Γ₀ depth hX) :
+    LR.CoherentRetainedAt Γ₀ hX depth := by
+  cases H with
+  | ordinary H => exact H.result
+  | focused H => exact H.elim fun origin => origin.retained
+  | carried _ H => exact H
+  | replayed _ _ H => exact H
+
+/-- A focused trace occurring inside one transported recursive-edge proof.
+The constructors mirror exactly the syntax-preserving operations admitted by
+`TransportClosure`. -/
+private inductive LR.FocusedTraceInProvenanceAt
+    (Γ₀ : List SExpr) (depth : Nat) (Y : SExpr) :
+    {X : SExpr} → {ρ : Valuation} → {root : TShape} →
+      {hX : LE_Interp.Witness ρ root X} →
+      LR.CoherentProvenanceAt Γ₀ depth hX → Prop where
+  | focused {hY : LE_Interp.Witness ρ root Y}
+      (origin : Nonempty (LR.FocusedRhsOriginAt Γ₀ depth hY)) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.base (.focused origin) : LR.CoherentProvenanceAt Γ₀ depth hY)
+  | replayed {hX : LE_Interp.Witness ρ root X}
+      (bundle : LR.FocusedRhsTraceBundleAt Γ₀ depth)
+      (current : bundle.contains X)
+      (retained : LR.CoherentRetainedAt Γ₀ hX depth) :
+      bundle.contains Y →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.base (.replayed bundle current retained) :
+          LR.CoherentProvenanceAt Γ₀ depth hX)
+  | carried {hX : LE_Interp.Witness ρ root X}
+      (bundle : LR.FocusedRhsTraceBundleAt Γ₀ depth)
+      (retained : LR.CoherentRetainedAt Γ₀ hX depth) :
+      bundle.contains Y →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.base (.carried bundle retained) :
+          LR.CoherentProvenanceAt Γ₀ depth hX)
+  | mono {ρ : Valuation} {root m : TShape}
+      {hX : LE_Interp.Witness ρ root X}
+      {H : LR.CoherentProvenanceAt Γ₀ depth hX} (hle : m ≤ root) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y H →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.mono (H := hX) hle H)
+  | mono_l {ρ ρ' : Valuation} {root : TShape}
+      {hX : LE_Interp.Witness ρ root X}
+      {H : LR.CoherentProvenanceAt Γ₀ depth hX} (hρ : ρ.LE ρ') :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y H →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.mono_l (H := hX) hρ H)
+  | join {ρ : Valuation} {root₁ root₂ : TShape}
+      {hX₁ : LE_Interp.Witness ρ root₁ X}
+      {hX₂ : LE_Interp.Witness ρ root₂ X}
+      {H₁ : LR.CoherentProvenanceAt Γ₀ depth hX₁}
+      {H₂ : LR.CoherentProvenanceAt Γ₀ depth hX₂}
+      (hJoin : LE_Interp.Witness ρ (root₁.join root₂) X) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y H₁ →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.join (H₁ := hX₁) (H₂ := hX₂) hJoin H₁ H₂)
+  | join_right {ρ : Valuation} {root₁ root₂ : TShape}
+      {hX₁ : LE_Interp.Witness ρ root₁ X}
+      {hX₂ : LE_Interp.Witness ρ root₂ X}
+      {H₁ : LR.CoherentProvenanceAt Γ₀ depth hX₁}
+      {H₂ : LR.CoherentProvenanceAt Γ₀ depth hX₂}
+      (hJoin : LE_Interp.Witness ρ (root₁.join root₂) X) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y H₂ →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.join (H₁ := hX₁) (H₂ := hX₂) hJoin H₁ H₂)
+  | closed {ρ ρ' : Valuation} {root : TShape}
+      {hX : LE_Interp.Witness ρ root X}
+      {H : LR.CoherentProvenanceAt Γ₀ depth hX}
+      (cl : ClosedN X k) (hρ : ∀ i < k, ρ i = ρ' i) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y H →
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y
+        (.closed (H := hX) cl hρ H)
+
+/-- Recover the action-indexed payload from a transported occurrence. -/
+private theorem LR.FocusedTraceInProvenanceAt.focusedTrace
+    {hX : LE_Interp.Witness ρ root X}
+    {H : LR.CoherentProvenanceAt Γ₀ depth hX}
+    (occurs : LR.FocusedTraceInProvenanceAt Γ₀ depth Y H) :
+    LR.FocusedRhsTraceAt Γ₀ depth Y := by
+  induction occurs with
+  | focused origin => exact ⟨_, _, _, origin⟩
+  | replayed bundle _ _ member => exact bundle.replay member
+  | carried bundle _ member => exact bundle.replay member
+  | mono _ _ ih => exact ih
+  | mono_l _ _ ih => exact ih
+  | join _ _ ih => exact ih
+  | join_right _ _ ih => exact ih
+  | closed _ _ _ ih => exact ih
+
+/-- A focused conversion trace occurring anywhere in one exact retained
+tree.  The `Y` index ensures a later rebuild can replay it only at an
+abstract edge for the same registered-head syntax. -/
+private inductive LR.FocusedTraceInRDeepAt
+    (Γ₀ : List SExpr) (depth : Nat) (Y : SExpr) :
+    ∀ {ρ root X} {hX : LE_Interp.Witness ρ root X},
+      hX.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) → Prop where
+  | app_fun {cf ca} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y cf →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (.app cf ca)
+  | app_arg {cf ca} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y ca →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (.app cf ca)
+  | lam_dom {cDom cBody} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y cDom →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (.lam cDom cBody)
+  | lam_body {cDom cBody} (x) (hx) :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (cBody x hx) →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (.lam cDom cBody)
+  | forall_dom₁ {cDom₁ cDom₂ cBody} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y cDom₁ →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.forallE cDom₁ cDom₂ cBody)
+  | forall_dom₂ {cDom₁ cDom₂ cBody} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y cDom₂ →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.forallE cDom₁ cDom₂ cBody)
+  | forall_body {cDom₁ cDom₂ cBody} (x) (hx) :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (cBody x hx) →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.forallE cDom₁ cDom₂ cBody)
+  | const_type {cType pEdge cEdge} :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y cType →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.const cType pEdge cEdge)
+  | const_edge {cType pEdge cEdge} (m) (e) (hr) :
+      LR.FocusedTraceInProvenanceAt Γ₀ depth Y (pEdge m e hr) →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.const cType pEdge cEdge)
+  | const_deep {cType pEdge cEdge} (m) (e) (hr) :
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y (cEdge m e hr) →
+      LR.FocusedTraceInRDeepAt Γ₀ depth Y
+        (.const cType pEdge cEdge)
+
+/-- Extract the action-indexed payload named by a tree occurrence. -/
+private theorem LR.FocusedTraceInRDeepAt.focusedTrace
+    {hX : LE_Interp.Witness ρ root X}
+    {children : hX.RDeepChildren
+      (LR.CoherentProvenanceAt Γ₀ depth)}
+    (occurs : LR.FocusedTraceInRDeepAt Γ₀ depth Y children) :
+    LR.FocusedRhsTraceAt Γ₀ depth Y := by
+  induction occurs with
+  | const_edge _ _ _ h => exact h.focusedTrace
+  | app_fun _ ih => exact ih
+  | app_arg _ ih => exact ih
+  | lam_dom _ ih => exact ih
+  | lam_body _ _ _ ih => exact ih
+  | forall_dom₁ _ ih => exact ih
+  | forall_dom₂ _ ih => exact ih
+  | forall_body _ _ _ ih => exact ih
+  | const_type _ ih => exact ih
+  | const_deep _ _ _ _ ih => exact ih
+
+/-- Package every focused occurrence in a retained tree without selecting a
+particular registered rule. -/
+private def LR.FocusedTraceInRDeepAt.bundle
+    {hX : LE_Interp.Witness ρ root X}
+    (children : hX.RDeepChildren
+      (LR.CoherentProvenanceAt Γ₀ depth)) :
+    LR.FocusedRhsTraceBundleAt Γ₀ depth := {
+  contains := fun Y =>
+    LR.FocusedTraceInRDeepAt Γ₀ depth Y children
+  replay := fun occurs => occurs.focusedTrace }
+
+/-- Rebuild the exact evaluator tree of a freshly selected witness at one
+strictly smaller syntax depth.
+
+Each abstract `R` child is traversed structurally before `seed` is invoked;
+the resulting consumer fact is therefore local to `depth` and cannot be
+promoted to the all-depth hypothesis reserved for genuine outer-recursion
+children. -/
+theorem LR.CoherentSeedAt.rebuild
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {hX : LE_Interp.Witness ρ root X} :
+    hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) :=
+  LE_Interp.Witness.RDeepChildren.of_step
+    (P := LR.CoherentSeedAt Γ₀ depth)
+    (fun hX children =>
+      LR.CoherentSeedAt.local (seed hX children)) hX
+
+/-- Use a completed strictly-smaller Nat rung at a freshly selected exact
+witness.
+
+The witness is not handed directly to `lower`: its evaluator tree is first
+rebuilt with depth-local seeds.  This is the reusable guarded restart for
+ordinary syntax children, semantic conversion endpoints, and dependent
+application witnesses. -/
+theorem LR.CoherentRetainedAt.restart
+    (lower : ∀ (d' : Nat), d' < outerDepth →
+      ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+        hX.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX d')
+    (hdepth : depth < outerDepth)
+    {hX : LE_Interp.Witness ρ root X} :
+    LR.CoherentRetainedAt Γ₀ hX depth := by
+  let children : hX.RDeepChildren
+      (LR.CoherentSeedAt Γ₀ depth) :=
+    LR.CoherentSeedAt.rebuild
+      (seed := fun hX children => lower depth hdepth hX children)
+  exact lower depth hdepth hX children
+
+/-- The guarded restart together with the exact rebuilt evaluator tree used
+to justify it. -/
+theorem LR.CoherentRetainedAt.restartWithTree
+    (lower : ∀ (d' : Nat), d' < outerDepth →
+      ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+        hX.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX d')
+    (hdepth : depth < outerDepth)
+    (hX : LE_Interp.Witness ρ root X) :
+    LR.CoherentRetainedAt Γ₀ hX depth ∧
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) := by
+  let children : hX.RDeepChildren
+      (LR.CoherentSeedAt Γ₀ depth) :=
+    LR.CoherentSeedAt.rebuild
+      (seed := fun hX children => lower depth hdepth hX children)
+  exact ⟨lower depth hdepth hX children, children⟩
 
-theorem LR.Adequate.refl
-    (H : ∀ {{σ σ'}}, LR.SubstWF Γ₀ σ σ' Γ ρ →
-      (LR Γ₀).DefEq (M.subst σ) (M.subst σ') (A.subst σ) m a) :
-    Adequate Γ₀ Γ ρ M M A m a := ⟨fun _ _ W => ⟨H W, H W⟩, fun _ W => H W⟩
+/-- THE DEPTH DISCHARGE.  The type rung follows from the *coherent* strict
+predecessor family that `LR.CoherentFixedHeadStep` already carries — no
+`LR.AdequacyAtDepth` at any rung, and nothing manufactured inside the
+induction.
 
-theorem LR.Adequate.left : Adequate Γ₀ Γ ρ M N A m a → Adequate Γ₀ Γ ρ M M A m a
-  | ⟨h1, _⟩ => .refl fun _ _ W => (h1 W).1
+Two facts make this work, and both are specific to this obligation.
 
-theorem LR.Adequate.symm : Adequate Γ₀ Γ ρ M N A m a → Adequate Γ₀ Γ ρ N M A m a
-  | ⟨h1, h2⟩ => ⟨fun _ _ W => (h1 W).symm, fun _ W => (LR _).symm (h2 W)⟩
+* The demand sits at `depth - 1` (`HasTypeStratifiedS.isType`), so it is a
+  strict predecessor exactly when `0 < depth`; `LR.CoherentRetainedAt.restart`
+  then supplies a completed rung at an **arbitrary** witness, rebuilding the
+  evaluator tree itself (`LR.CoherentSeedAt.rebuild`).  The witness needed
+  here — the registered type's own interpretation — is not a child of the
+  fixed head's witness, so the `children` tree could not have supplied it;
+  the guarded restart is what makes an unrelated witness admissible.
+* The conclusion is **homogeneous** (`TyDefEq headType headType headElemTy`),
+  and `LR.CoherentRetainedAt` carries exactly homogeneous self-adequacy.
+  This is precisely why the same move does *not* discharge
+  `LR.SelfAdequateDefeqStepAt`, whose conversion callback needs
+  `LR.Adequate Γ₀ Γ ρ A B (.sort u) ma sa` with two *different* endpoints. -/
+theorem LR.FixedHeadTypeValidStep.of_lowerCoherent
+    {depth : Nat} (hdepth : 0 < depth)
+    (lower : ∀ (d' : Nat), d' < depth → ∀ {ρ root X}
+      (hX' : LE_Interp.Witness ρ root X),
+      hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+      LR.CoherentRetainedAt Γ₀ hX' d') :
+    LR.FixedHeadTypeValidStep Γ₀ depth := by
+  intro Δ ρ σ σ' X headType core n headElem headElemTy W hstrat
+    hTypeClosed htyped hTy
+  obtain ⟨u, hTypeStrat⟩ := hstrat.isType
+  have hTypeStrong : IsDefEqStrong Δ headType headType (.sort u) :=
+    hTypeStrat.strong
+  obtain ⟨n', typeElem, sortElem, le_n, le_type,
+      hTypeInterp, hSortInterp, hTypeTyped⟩ :=
+    (LE_Interp.sound hTypeStrong W.left.fits).2 hTy.toInterp |>.out
+  have hselfTy : LR.SelfAdequateAt Γ₀ hTypeInterp.witness (depth - 1) :=
+    (LR.CoherentRetainedAt.restart lower
+      (Nat.sub_lt hdepth Nat.one_pos) (hX := hTypeInterp.witness)).1
+  have hTypeAdequate :=
+    (hselfTy .rfl hTypeStrat hTypeTyped hSortInterp.witness).2 W.left
+  simp only [SExpr.subst] at hTypeAdequate
+  rw [hTypeClosed.subst_eq .zero] at hTypeAdequate
+  exact LR.toValTy le_n le_type htyped.isType
+    hSortInterp hTypeTyped hTypeAdequate
 
-theorem LR.Adequate.trans :
-    Adequate Γ₀ Γ ρ M₁ M₂ A m a → Adequate Γ₀ Γ ρ M₂ M₃ A m a → Adequate Γ₀ Γ ρ M₁ M₃ A m a
-  | ⟨a1, a2⟩, ⟨b1, b2⟩ =>
-    ⟨fun _ _ W => ⟨(a1 W).1, (b1 W).2⟩, fun _ W => (LR _).trans (a2 W) (b2 W)⟩
+/-- The depth-zero rung, where `of_lowerCoherent`'s strict decrease is
+unavailable, is nevertheless free.
 
-theorem LR.Adequate.trans' : Adequate Γ₀ Γ ρ A₁ A₂ (.sort u) a s →
-    Adequate Γ₀ Γ ρ A₂ A₃ (.sort v) a (.sort r) → Adequate Γ₀ Γ ρ A₁ A₃ (.sort u) a s
-  | ⟨a1, a2⟩, ⟨b1, b2⟩ => by
-    refine ⟨fun σ σ' W => ⟨(a1 W).1, ?_⟩, fun _ W => (LR _).trans' (a2 W) (b2 W)⟩
-    have h1 := (LR _).trans' (a1 W.left).2 (b2 W.left)
-    have h2 := (LR _).trans' (a1 W.symm.left).2 (b2 W.symm.left)
-    exact (LR _).trans ((LR _).symm h1) <| (LR _).trans (a1 W).2 h2
+Every `HasTypeStratifiedS` constructor except `sort'` and `base` carries the
+index `n + 1`, so a depth-`0` certificate forces the subject to be a sort and
+its displayed type to be the successor sort.  That case needs no adequacy at
+all: the fixed-head displayed type is then a sort, and its validity at the
+observation is the `sort_iff` / `bot` split already used by the `sort'` case
+of `LR.selfAdequateExactAtStep`. -/
+theorem LR.FixedHeadTypeValidStep.zero : LR.FixedHeadTypeValidStep Γ₀ 0 := by
+  intro Δ ρ σ σ' X headType core n headElem headElemTy W hstrat
+    hTypeClosed htyped hTy
+  obtain ⟨u, hTypeStrat⟩ := hstrat.isType
+  have hTypeStrong : IsDefEqStrong Δ headType headType (.sort u) :=
+    hTypeStrat.strong
+  obtain ⟨n', typeElem, sortElem, le_n, le_type,
+      hTypeInterp, hSortInterp, hTypeTyped⟩ :=
+    (LE_Interp.sound hTypeStrong W.left.fits).2 hTy.toInterp |>.out
+  refine LR.toValTy le_n le_type htyped.isType hSortInterp hTypeTyped ?_
+  have hsort : ∃ l : SLevel, headType = .sort l.succ := by
+    cases hstrat with
+    | sort' => exact ⟨_, rfl⟩
+    | base h => cases h with | sort' => exact ⟨_, rfl⟩
+  obtain ⟨l, rfl⟩ := hsort
+  cases hTypeTyped.unfold with
+  | bot hm => exact (LR _).bot hm
+  | sort => exact (LR _).sort_iff.2 ⟨_, .rfl, .rfl⟩
+  | _ =>
+    obtain h | h := WShape.le_sort.1 hTypeInterp.le_sort'
+    · dsimp only at h
+      rw [h]
+      exact (LR _).bot hTypeTyped.isType
+    · simp [WShape.ext_iff, WShape.forallE, WShape.sort, Shape.sort,
+        WShape.lam', WShape.lam, WShape.bot, WShape.ctor, WShape.indTy,
+        Shape.bot] at h <;>
+        first
+        | split at h <;> simp_all only [reduceCtorEq]
+        | simp_all
 
-theorem LR.Adequate.cons
-    (ihA : ∀ {ρ n} {m a : WShape n}, LE_Interp ρ m.T A → LE_Interp ρ a.T (.sort u) →
-      m.HasType a → Adequate Γ₀ Γ ρ A A' (sort u) m a)
-    (HA : Γ ⊢ A ≡ A' : .sort u)
-    {{k : Nat}} {{a₁ p : WShape k}} {{x x' σ σ' ρ}}
-    (hp : p.HasType a₁) (hA₁ : LE_Interp ρ a₁.T A)
-    (hx : Γ₀ ⊢ x ≡ x' : A.subst σ) (hv : (LR Γ₀).DefEq x x' (A.subst σ) p a₁)
-    (W : SubstWF Γ₀ σ σ' Γ ρ) : SubstWF Γ₀ (σ.cons x) (σ'.cons x') (A :: Γ) (ρ.push p.T) := by
-  refine W.cons (fun hA => ?_) hA₁ hp.T HA.hasType.1 ⟨hx, fun n a' ha' => ?_⟩
-  · have ⟨_, _, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.fits).2 hA
-    exact ⟨_, le_a, hA', (TShape.HasType.mono_r hSort.le_sort .sort hmem').toType⟩
-  have ha' := LE_Interp.weak_iff.1 ha'
-  refine ⟨fun ht => ⟨⟨_, HA.hasType.1.subst W.toSubstEq⟩, ?_⟩, fun m' hm' ht => ?_⟩
-  · have ⟨_, _, _, le_n, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.fits).2 ha' |>.out
-    refine (TyDefEq.lift le_n ht).1 <| (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
-      (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht)
-      (WShape.HasType.mono_r hSort.le_sort' .sort hmem').toType ?_
-    exact (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
-      (.mono_r hSort.le_sort' .sort hmem') .sort ((ihA hA' hSort hmem').1 W).1
-  · have le_k := Nat.le_max_left k n; have le_n := Nat.le_max_right k n
-    have ht' := (WShape.HasType.lift le_n).2 ht
-    have hp' := (WShape.HasType.lift le_k).2 hp
-    have hle' := (TShape.LE.def le_n le_k).1 (LE_Interp.bvar_iff.1 hm')
-    have hta₁ := WShape.lift_type ▸ (WShape.HasType.lift le_k).2 hp.isType
-    have hta' := WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht.isType
-    have hc := hA₁.compat ha'
-    have hj := (TShape.Join.def le_k le_n (Nat.le_refl _)).1 (.mk hc)
-    rw [TShape.lift_join le_k le_n] at hj
-    have ⟨hj1, hj2⟩ := hj.le
-    have hJ := hta₁.join' hj hta'
-    have hJ' := hJ.mono_r hj1 hp'
-    refine (DefEq.lift le_n ht).1 <|
-      (LR Γ₀).mono_r_2 hj2 ht' hJ <|
-      (LR Γ₀).mono_l hle' (hJ.mono_r hj2 ht') hJ' <|
-      (LR Γ₀).mono_r_1 hj1 hp' hJ' ?_ <| (DefEq.lift le_k hp).2 hv
-    have valTyA {nd : Nat} {a : WShape nd} (hA : LE_Interp ρ a.T A) (ha : a.HasType .type) :
-        (LR Γ₀).TyDefEq (A.subst σ) (A.subst σ) a :=
-      have ⟨_, _, _, le_n, le_a, hA', hSort, hmem'⟩ := (LE_Interp.sound HA W.left.fits).2 hA |>.out
-      have v2 := (ihA hA' hSort hmem').2 W.left
-      have vt := (LR Γ₀).left_ty <| (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hSort.le_sort' hmem'
-        (.mono_r hSort.le_sort' .sort hmem') .sort v2
-      (TyDefEq.lift le_n ha).1 <| (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
-        (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ha)
-        (WShape.HasType.mono_r hSort.le_sort' .sort hmem').toType vt
-    refine (LR Γ₀).join_ty ((TShape.Compat.def le_k le_n).2 hc) hta₁ hta' ?_ ?_
-    · exact (TyDefEq.lift le_k hp.isType).2 (valTyA hA₁ hp.isType)
-    · exact (TyDefEq.lift le_n ht.isType).2 (valTyA ha' ht.isType)
+/-- The whole family at one rung, from the coherent predecessor family alone.
+This is what `LR.CoherentFixedHeadStep.of_convertStep` consumes, and it is why
+`∀ depth, LR.FixedHeadTypeValidStep Γ₀ depth` is no longer an obligation. -/
+theorem LR.FixedHeadTypeValidStep.of_coherentLower
+    {depth : Nat}
+    (lower : ∀ (d' : Nat), d' < depth → ∀ {ρ root X}
+      (hX' : LE_Interp.Witness ρ root X),
+      hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+      LR.CoherentRetainedAt Γ₀ hX' d') :
+    LR.FixedHeadTypeValidStep Γ₀ depth := by
+  rcases Nat.eq_zero_or_pos depth with rfl | hdepth
+  · exact LR.FixedHeadTypeValidStep.zero
+  · exact LR.FixedHeadTypeValidStep.of_lowerCoherent hdepth lower
 
-/-- Extract `TyDefEq` from a `DefEq` at sort type. -/
-theorem LR.toValTy {m : WShape n'} {b : WShape n} (le_n : n ≤ n') (le_a : b.T ≤ m.T)
-    (ht : b.HasType .type) (hSort : LE_Interp ρ a.T (.sort u)) (hmem' : m.HasType a)
-    (H : (LR Γ₀).DefEq M N (.sort u) m a) : (LR Γ₀).TyDefEq M N b := by
-  have hle := hSort.le_sort'
-  refine (LR.TyDefEq.lift le_n ht).1 ?_
-  refine (LR Γ₀).mono_r_2_ty ((TShape.LE.lift_l le_n).1 le_a)
-    (WShape.lift_type ▸ (WShape.HasType.lift le_n).2 ht)
-    (WShape.HasType.mono_r hle .sort hmem').toType ?_
-  exact (LR Γ₀).toType <| (LR Γ₀).mono_r_1 hle hmem'
-    (.mono_r hle .sort hmem') .sort H
+/-- Rebuild a transportable semantic-typing tree from an inspectable local
+seed constructor.  The transport closure is introduced only after the
+underlying witness has obtained a canonical `CoherentSeedAt` tree. -/
+theorem LR.CoherentProvenanceAt.rebuild
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {hX : LE_Interp.Witness ρ root X} :
+    hX.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) :=
+  LE_Interp.Witness.RDeepChildren.of_step
+    (P := LR.CoherentProvenanceAt Γ₀ depth)
+    (fun hX _children => LR.CoherentProvenanceAt.local <|
+      seed hX (LR.CoherentSeedAt.rebuild seed)) hX
+
+/-- Rebuild a freshly selected conversion endpoint while retaining every
+focused action trace exposed by the source tree.
+
+The endpoint witness and its retained result are still selected locally by
+the guarded `seed`.  Each new recursive edge receives the whole source trace
+bundle, so transport does not guess which registered rule a later fixed-head
+consumer will request.  The bundle restores only proof-relevant origins; it
+neither reuses a foreign witness nor promotes the local result to the
+all-depth branch. -/
+private theorem LR.CoherentProvenanceAt.rebuildTracingFocused
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {hSource : LE_Interp.Witness ρSource sourceRoot sourceX}
+    (source : hSource.RDeepChildren
+      (LR.CoherentProvenanceAt Γ₀ depth))
+    {hX : LE_Interp.Witness ρ root X} :
+    hX.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) := by
+  classical
+  let bundle : LR.FocusedRhsTraceBundleAt Γ₀ depth :=
+    LR.FocusedTraceInRDeepAt.bundle source
+  apply LE_Interp.Witness.RDeepChildren.of_step
+    (P := LR.CoherentProvenanceAt Γ₀ depth)
+  intro ρ' root' X' hX' _children
+  let retained : LR.CoherentRetainedAt Γ₀ hX' depth :=
+    seed hX' (LR.CoherentSeedAt.rebuild seed)
+  by_cases current : bundle.contains X'
+  · exact .base (.replayed bundle current retained)
+  · exact .base (.carried bundle retained)
+
+/-- Rebuild a converted endpoint while tagging exactly the lowerings of one
+focused iota head witness with their action-indexed origin.
+
+The structural traversal still computes every local retained result through
+the guarded `seed`.  At an abstract evaluator edge it additionally checks
+whether the reached proof-relevant witness is literally a realization of the
+focused preimage's `LowerEdge`.  Only that witness receives `.focused`; all
+other children receive the ordinary local injection. -/
+theorem LR.CoherentProvenanceAt.rebuildFocused
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {rule : Pattern.IotaRule r}
+    {Gamma : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {A : SExpr} {rho : Valuation} {rhsRoot : TShape}
+    {action : Pattern.Action Gamma r e ls capture A}
+    {rhsWitness : LE_Interp.Witness rho rhsRoot
+      (r.1.applyS ls capture)} {rhsDepth : Nat}
+    (preimage : rule.FocusedActionPreimage action rhsWitness rhsDepth)
+    {root : TShape} {X : SExpr}
+    (hX : LE_Interp.Witness rho root X) :
+    hX.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) := by
+  apply LE_Interp.Witness.RDeepChildren.of_step
+    (P := LR.CoherentProvenanceAt Γ₀ depth)
+  intro rho' root' X' hX' _children
+  let retained : LR.CoherentRetainedAt Γ₀ hX' depth :=
+    seed hX' (LR.CoherentSeedAt.rebuild seed)
+  by_cases hρ : rho' = rho
+  · subst rho'
+    by_cases hEdge : ∃ edge : preimage.headWitness.LowerEdge root' X',
+        hX' = edge.realize
+    · obtain ⟨edge, realizes⟩ := hEdge
+      exact .base (.focused ⟨{
+        recName := rec
+        ctorName := ctor
+        major := major
+        arity := arity
+        r := r
+        rule := rule
+        Gamma := Gamma
+        e := e
+        ls := ls
+        capture := capture
+        A := A
+        action := action
+        rhsRoot := rhsRoot
+        rhsWitness := rhsWitness
+        rhsDepth := rhsDepth
+        preimage := preimage
+        edge := edge
+        realizes := realizes
+        retained := retained }⟩)
+    · exact .base (.ordinary (.inr retained))
+  · exact .base (.ordinary (.inr retained))
+
+/-- Lowering the observed root preserves depth-indexed self-adequacy; the
+selected evaluator tree and displayed type witness are unchanged. -/
+theorem LR.SelfAdequateAt.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.SelfAdequateAt Γ₀ hX depth) :
+    LR.SelfAdequateAt Γ₀ (hX.mono hle) depth := by
+  intro n mx bx Δ core B hroot hTyping htyped hB
+  exact H (hroot.trans hle) hTyping htyped hB
+
+/-- A result constructed at a larger stratification depth also handles every
+smaller depth: raise the caller's typing certificate before consuming it. -/
+theorem LR.SelfAdequateAt.of_le
+    (hdepth : depth ≤ outerDepth)
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.SelfAdequateAt Γ₀ hX outerDepth) :
+    LR.SelfAdequateAt Γ₀ hX depth := by
+  intro n mx bx Δ core B hroot hTyping htyped hB
+  exact H hroot (hTyping.mono hdepth) htyped hB
+
+/-- Fixed-head validity is contravariant in its explicit typing-depth index.
+Only the stratification premise changes; the generated application result is
+independent of which enlarged certificate discharged it. -/
+theorem LR.FixedHeadResultAt.of_le
+    (hdepth : depth ≤ outerDepth)
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.FixedHeadResultAt Γ₀ hX outerDepth) :
+    LR.FixedHeadResultAt Γ₀ hX depth := by
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead hstrong hstrat hshape
+    htel hTyReg hspineX hspineY hcap hout hA
+  exact H W hsyntax hhead hstrong (hstrat.mono hdepth) hshape htel hTyReg
+    hspineX hspineY hcap hout hA
+
+/-- Lower the depth of both halves of the coherent retained package. -/
+theorem LR.CoherentRetainedAt.of_le
+    (hdepth : depth ≤ outerDepth)
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedAt Γ₀ hX outerDepth) :
+    LR.CoherentRetainedAt Γ₀ hX depth :=
+  ⟨LR.SelfAdequateAt.of_le (hX := hX) hdepth H.1,
+    LR.FixedHeadResultAt.of_le (hX := hX) hdepth H.2⟩
+
+/-- Lower a seed's usable depth without changing its provenance class.
+Genuine evaluator children remain all-depth; rebuilt children remain local. -/
+theorem LR.CoherentSeedAt.of_le
+    (hdepth : depth ≤ outerDepth)
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentSeedAt Γ₀ outerDepth hX) :
+    LR.CoherentSeedAt Γ₀ depth hX := by
+  cases H with
+  | inl H => exact .inl H
+  | inr H => exact .inr (LR.CoherentRetainedAt.of_le hdepth H)
+
+/-- Bottom observations are self-adequate at every syntax depth. -/
+theorem LR.SelfAdequateAt.bot
+    {nroot : Nat} {X : SExpr} (depth : Nat) :
+    LR.SelfAdequateAt Γ₀
+      (LE_Interp.Witness.bot (ρ := ρ) (n := nroot) (M := X)) depth := by
+  intro n mx bx Δ core B hroot _hTyping htyped _hB
+  have hmxBot : mx.T ≤ TShape.bot :=
+    hroot.trans TShape.bot_eqv.1
+  have hmx : mx = .bot := TShape.le_bot.1 hmxBot
+  subst mx
+  exact LR.Adequate.bot htyped.isType
+
+/-- The coherent package is stable under root lowering, one of the primitive
+operations recorded by `TransportClosure`. -/
+theorem LR.CoherentRetainedResult.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.CoherentRetainedResult Γ₀ hX) :
+    LR.CoherentRetainedResult Γ₀ (hX.mono hle) := by
+  intro depth
+  have hself : LR.SelfAdequateAt Γ₀ hX depth := (H depth).1
+  have hfixed : LR.FixedHeadResultAt Γ₀ hX depth := (H depth).2
+  exact ⟨LR.SelfAdequateAt.mono (hX := hX) hle hself,
+    LR.FixedHeadResultAt.mono (hX := hX) hle hfixed⟩
+
+/-- Root lowering preserves both halves of a coherent result at one depth. -/
+theorem LR.CoherentRetainedAt.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.CoherentRetainedAt Γ₀ hX depth) :
+    LR.CoherentRetainedAt Γ₀ (hX.mono hle) depth :=
+  ⟨LR.SelfAdequateAt.mono (hX := hX) hle H.1,
+    LR.FixedHeadResultAt.mono (hX := hX) hle H.2⟩
+
+/-- Lowering the selected RHS observation preserves its coupled provenance
+and local typing budget. -/
+theorem LR.CoherentRhsSeedAt.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.CoherentRhsSeedAt Γ₀ Δ depth hX B) :
+    LR.CoherentRhsSeedAt Γ₀ Δ depth (hX.mono hle) B := by
+  cases H with
+  | inl H => exact .inl (LR.CoherentRetainedResult.mono hle H)
+  | inr H => exact .inr ⟨LR.CoherentRetainedAt.mono hle H.1, H.2⟩
+
+/-- Couple an inspectable evaluator seed with the exact RHS typing
+certificate available at this conversion depth.
+
+The genuine-child branch keeps its all-depth result and does not depend on
+the certificate.  The rebuilt branch records the certificate alongside the
+local result, which is precisely the asymmetric contract consumed by the
+coherent iota leaf. -/
+theorem LR.CoherentRhsSeedAt.of_seed
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentSeedAt Γ₀ depth hX)
+    (hstrat : HasTypeStratifiedS Δ X B true depth) :
+    LR.CoherentRhsSeedAt Γ₀ Δ depth hX B := by
+  cases H with
+  | inl H => exact .inl H
+  | inr H => exact .inr ⟨H, hstrat⟩
+
+/-- A focused evaluator edge preserves the coupled RHS package by literal
+root lowering of its generating witness. -/
+theorem LR.CoherentRhsSeedAt.of_lowerEdge
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRhsSeedAt Γ₀ Δ depth hX B)
+    (edge : hX.LowerEdge m M) :
+    LR.CoherentRhsSeedAt Γ₀ Δ depth edge.realize B := by
+  obtain ⟨rfl, hle⟩ := edge
+  exact LR.CoherentRhsSeedAt.mono (hX := hX) hle H
+
+/-- Root lowering preserves whether an evaluator edge carries the genuine
+all-depth result or only the result at the current guarded restart depth.
+
+Keeping the injection unchanged is important: lowering an exact witness is
+a structural transport and must not promote a local seed to the all-depth
+side reserved for genuine outer-recursion children. -/
+theorem LR.CoherentSeedAt.mono
+    (hle : root ≤ root')
+    {hX : LE_Interp.Witness ρ root' X}
+    (H : LR.CoherentSeedAt Γ₀ depth hX) :
+    LR.CoherentSeedAt Γ₀ depth (hX.mono hle) := by
+  cases H with
+  | inl H =>
+    exact .inl (LR.CoherentRetainedResult.mono
+      (hX := hX) hle H)
+  | inr H =>
+    exact .inr (LR.CoherentRetainedAt.mono (hX := hX) hle H)
+
+/-- Coherent base case corresponding to `TransportClosure.bot`. -/
+theorem LR.CoherentRetainedResult.bot
+    {nroot : Nat} {X : SExpr} :
+    LR.CoherentRetainedResult Γ₀
+      (LE_Interp.Witness.bot (ρ := ρ) (n := nroot) (M := X)) := by
+  intro depth
+  have hfixed : LR.FixedHeadResult Γ₀
+      (LE_Interp.Witness.bot (ρ := ρ) (n := nroot) (M := X)) :=
+    LR.FixedHeadResult.bot
+  exact ⟨LR.SelfAdequateAt.bot depth,
+    LR.FixedHeadResult.at
+      (hX := LE_Interp.Witness.bot (ρ := ρ) (n := nroot) (M := X))
+      hfixed depth⟩
+
+/-- The evaluator-coherent consumer algebra.
+
+This is the sole producer contract for the repaired recursion: genuine
+semantic children carry the full depth-polymorphic result, while witnesses
+created later by root/valuation/closed transport or compatible join carry a
+free `TransportClosure` proof instead of an unjustified consumer result. -/
+def LR.CoherentRetainedStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+    hX.RDeepChildren
+      (LE_Interp.Witness.TransportClosure
+        (LR.CoherentRetainedResult Γ₀)) →
+    LR.CoherentRetainedResult Γ₀ hX
+
+/-- The executable evaluator-coherent algebra, with the Nat decrease exposed
+at the point where syntax recursion may select another witness.
+
+Unlike `CoherentRetainedStep`, a lower-depth restart is not global: the new
+witness must carry a complete `CoherentSeedAt` tree.  Every local seed in
+that tree is attached only after structural descent through the selected
+witness and remains pinned to the smaller Nat index.  This is the
+proof-relevant side condition that rules out the old “lower depth, restart
+anywhere” cycle while still admitting witnesses selected by conversion. -/
+def LR.CoherentRetainedNatStep (Γ₀ : List SExpr) : Prop :=
+  ∀ (depth : Nat) {ρ root X}
+      (hX : LE_Interp.Witness ρ root X),
+    hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+    (∀ (d' : Nat), d' < depth →
+      ∀ {ρ root X} (hX' : LE_Interp.Witness ρ root X),
+        hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX' d') →
+    LR.CoherentRetainedAt Γ₀ hX depth
+
+/-- Self-adequacy half of the provenance-checked Nat algebra. -/
+def LR.CoherentSelfStep (Γ₀ : List SExpr) : Prop :=
+  ∀ (depth : Nat) {ρ root X}
+      (hX : LE_Interp.Witness ρ root X),
+    hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+    (∀ (d' : Nat), d' < depth →
+      ∀ {ρ root X} (hX' : LE_Interp.Witness ρ root X),
+        hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX' d') →
+    LR.SelfAdequateAt Γ₀ hX depth
+
+/-- Fixed-head half of the provenance-checked Nat algebra.  It receives the
+self-adequacy result constructed at the same witness and depth, so the
+ordered telescope never has to recover that fact from a transported child. -/
+def LR.CoherentFixedHeadStep (Γ₀ : List SExpr) : Prop :=
+  ∀ (depth : Nat) {ρ root X}
+      (hX : LE_Interp.Witness ρ root X),
+    LR.SelfAdequateAt Γ₀ hX depth →
+    hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+    (∀ (d' : Nat), d' < depth →
+      ∀ {ρ root X} (hX' : LE_Interp.Witness ρ root X),
+        hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX' d') →
+    LR.FixedHeadResultAt Γ₀ hX depth
+
+/-- Assemble the two consumer-specific algebras without hiding either
+well-founded input. -/
+theorem LR.CoherentRetainedNatStep.of_steps
+    (selfStep : LR.CoherentSelfStep Γ₀)
+    (fixedStep : LR.CoherentFixedHeadStep Γ₀) :
+    LR.CoherentRetainedNatStep Γ₀ := by
+  intro depth ρ root X hX children lower
+  have hself : LR.SelfAdequateAt Γ₀ hX depth :=
+    selfStep depth hX children lower
+  exact ⟨hself, fixedStep depth hX hself children lower⟩
+
+/-- THE FIXED-HEAD HALF OF THE COHERENT NAT ALGEBRA.
+
+Neither the seed tree nor the strict predecessor family is consumed.  Once the
+N2 premise change hands the step its ordered capture telescope together with
+the registered type's own witness at one index, the fixed-head half is a pure
+fold: its only semantic inputs are the self-adequacy result supplied at the
+same witness and the same depth by `LR.CoherentRetainedNatStep.of_steps`, and
+the two named obligations below.  The redundant existential capture family is
+never opened — the telescope already carries every capture at its own shapes,
+which is exactly what the N2 decision was for.
+
+Both closedness facts are free, and neither needs a new field on
+`Pattern.IotaRule`.  The generated RHS is closed by `rhsClosed`; the
+*registered type* is closed by `Params.henv.closed`, i.e. by the environment's
+own ordering invariant.  The `typeClosed` field the previous port recorded as
+missing is not needed after all.
+
+The bottom observation is discharged before any of that, exactly as in
+`LR.FixedHeadResult.bot`: a bottom result shape forces `out = .bot`. -/
+theorem LR.CoherentFixedHeadStep.of_steps
+    (convert : LR.FixedHeadConvertStep Γ₀)
+    (typeValid : ∀ depth, LR.FixedHeadTypeValidStep Γ₀ depth) :
+    LR.CoherentFixedHeadStep Γ₀ := by
+  intro depth ρ root X hX hself _children _lower
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead _hstrong hstrat hshape
+    htel hTyReg hspineX _hspineY _hcap hout hA
+  subst hsyntax
+  by_cases hbot : out.T ≤ TShape.bot
+  · have houtEq : out = .bot := TShape.le_bot.1 hbot
+    subst houtEq
+    exact (LR Γ₀).bot hout.isType
+  · exact LR.FixedHeadApplication.applyRule (hX := hX)
+      (htel.toApplicationWithSelfAdequacy (hX := hX) hTyReg hbot hspineX hA
+        convert hself (typeValid depth) hhead hstrat W
+        rule.rhsClosed.mkInstS (rule.typeClosed recLs))
+
+/-- THE FIXED-HEAD HALF, with the type rung discharged rather than assumed.
+
+Identical to `of_steps` except that the `typeValid` family is no longer a
+hypothesis: `LR.FixedHeadTypeValidStep.of_coherentLower` builds the instance
+needed at this rung out of `lower`, the step's own strict predecessor family.
+`of_steps` is kept unchanged as the reference statement (the treatment
+`LR.FixedHeadTelescope.toApplicationWithAdequacyAtDepth` and
+`LR.ConstDefnLocalStep` also received).
+
+G4: `lower` arrives through the step interface — `LR.CoherentRetainedNatStep`
+hands it over from `recRDeepNatProvenance` — and is consumed only through the
+sanctioned guarded restart `LR.CoherentRetainedAt.restart`, exactly as
+`LR.selfAdequateExactAtStep` already consumes it.  Nothing predecessor-shaped
+is manufactured inside the induction, and no index a consumer fixed is
+re-chosen. -/
+theorem LR.CoherentFixedHeadStep.of_convertStep
+    (convert : LR.FixedHeadConvertStep Γ₀) :
+    LR.CoherentFixedHeadStep Γ₀ := by
+  intro depth ρ root X hX hself _children lower
+  intro Δ σ σ' W n rec ctor major arity recLs mrec mctor r rule out head
+    headTy mx my captureType A outTy hsyntax hhead _hstrong hstrat hshape
+    htel hTyReg hspineX _hspineY _hcap hout hA
+  subst hsyntax
+  by_cases hbot : out.T ≤ TShape.bot
+  · have houtEq : out = .bot := TShape.le_bot.1 hbot
+    subst houtEq
+    exact (LR Γ₀).bot hout.isType
+  · exact LR.FixedHeadApplication.applyRule (hX := hX)
+      (htel.toApplicationWithSelfAdequacy (hX := hX) hTyReg hbot hspineX hA
+        convert hself (LR.FixedHeadTypeValidStep.of_coherentLower lower)
+        hhead hstrat W
+        rule.rhsClosed.mkInstS (rule.typeClosed recLs))
+
+/-- Close the semantic fixed point from one provenance-sensitive algebra.
+No typing-depth index is fixed before following an evaluator `R` edge. -/
+theorem LR.coherentRetainedResult_of_step
+    (step : LR.CoherentRetainedStep Γ₀)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) :
+    LR.CoherentRetainedResult Γ₀ hX :=
+  hX.recRDeepTransport step
+
+/-- Close the coherent result from the provenance-checked Nat algebra.
+Semantic `R` descent supplies every depth; arbitrary witness changes are
+available only at a strict Nat decrease and with their transport certificate
+still attached. -/
+theorem LR.coherentRetainedResult_of_natStep
+    (step : LR.CoherentRetainedNatStep Γ₀)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X) :
+    LR.CoherentRetainedResult Γ₀ hX := by
+  exact hX.recRDeepNatProvenance
+    (Q := fun hX depth => LR.CoherentRetainedAt Γ₀ hX depth)
+    step
+
+/-- Forget the coherent construction after selecting its fixed-head half at
+every stratification depth. -/
+theorem LR.CoherentRetainedResult.fixedHead
+    {hX : LE_Interp.Witness ρ root X}
+    (H : LR.CoherentRetainedResult Γ₀ hX) :
+    LR.FixedHeadResult Γ₀ hX := by
+  apply LR.FixedHeadResult.of_forall_at
+  exact fun depth => (H depth).2
+
+/-- The exact iota leaf follows from the provenance-checked Nat algebra.
+
+This is the formal statement of the residual gap at the abstract-evaluator
+leaf: once `CoherentRetainedNatStep` is instantiated, every closed-valuation
+witness carries the full coherent result, whose fixed-head half discharges
+the generated RHS obligation of one native exact link through
+`iotaDefEq_of_ctorExactAt_closedFixedHead`. -/
+theorem LRS.iotaDefEq_of_ctorExactAt_natStep
+    {n : Nat}
+    {R : TShape → SExpr → Prop} {ρ : Valuation}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    (step : LR.CoherentRetainedNatStep Γ₀)
+    (producer : ∀ (rule : Pattern.IotaRule r) {head : TShape}
+      (mx my captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      {outTyP : WShape (n + 1)}
+      (hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T),
+      LR.FixedHeadProducer Γ₀ Valuation.nil rule mx my captureType hshape
+        (recLs := recLs) (outTy := outTyP))
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      (LE_Interp.Lower R) out.T r.1)
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (leaf : LRS.CtorExact Γ₀ (LR Γ₀) majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LR Γ₀) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LR Γ₀).TyDefEq A A outTy) :
+    (LR Γ₀).DefEq
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy :=
+  LRS.iotaDefEq_of_ctorExactAt_closedFixedHead hΓ hpat hmf hma hrhs hR
+    (fun hX =>
+      (LR.coherentRetainedResult_of_natStep step hX).fixedHead)
+    producer leaf hleaf hrecHead hout hA
+
+/-- Close one exact constructor iota leaf from provenance-sensitive
+fixed-head seeds at a single stratification depth.
+
+Unlike `iotaDefEq_of_ctorExactAt_fixedHead`, this theorem does not erase a
+local guarded restart into an all-depth result.  A genuine semantic child
+chooses the registered RHS's native stratification depth from its all-depth
+result.  Only a local child needs the RHS typing raised to the exact `depth`
+carried by its right injection. -/
+theorem LRS.iotaDefEq_of_ctorExactAt_coherent
+    {n : Nat}
+    {R : TShape → SExpr → Prop} {ρ : Valuation}
+    {rec ctor : Name} {major arity : Nat}
+    {recShapes : List (WShape (n + 1))}
+    {ctorShapes : List (WShape n)}
+    {mrec : (Pattern.varN (.const rec) major).Path → TShape}
+    {mctor : (Pattern.varN (.const ctor) arity).Path → TShape}
+    {recXs recYs : List SExpr} {recLs : List SLevel}
+    {majorX majorY recHeadType A : SExpr}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    {out outTy : WShape (n + 1)}
+    {hwf : IsStruct ctor → WShape.ListNonZero ctorShapes.reverse}
+    {Δ : List SExpr} {σ σ' : Subst} {depth : Nat}
+    (W : LR.SubstWF Γ₀ σ σ' Δ ρ)
+    (hΓ : Ctx.WF Γ₀)
+    (hpat : Params.Pat (RecursorIotaPattern rec major ctor arity) r)
+    (hmf : LE_Interp.Matches (n := n + 1)
+      (Pattern.varN (.const rec) major) rec recShapes mrec)
+    (hma : LE_Interp.Matches (n := n)
+      (Pattern.varN (.const ctor) arity) ctor ctorShapes mctor)
+    (hrhs : LE_Interp.RHS recLs (Sum.elim mrec mctor)
+      (LE_Interp.Lower R) out.T r.1)
+    (hR : ∀ {m M}, R m M → LE_Interp.Witness ρ m M)
+    (hP : ∀ (rule : Pattern.IotaRule r) {m}
+      (hr : R m (SExpr.mkInst recLs rule.df.rhs)),
+      LR.CoherentRhsSeedAt Γ₀ Δ depth (hR hr)
+        (SExpr.mkInst recLs rule.df.type))
+    (producer : ∀ (rule : Pattern.IotaRule r) {head : TShape}
+      (mx my captureType :
+        (RecursorIotaPattern rec major ctor arity).Path → SExpr)
+      {outTyP : WShape (n + 1)}
+      (hshape : LE_Interp.RHS.ShapeSpine (Sum.elim mrec mctor)
+        head rule.capturePaths out.T),
+      LR.FixedHeadProducer Γ₀ ρ rule mx my captureType hshape
+        (recLs := recLs) (outTy := outTyP))
+    (leaf : LRS.CtorExact Γ₀ (LR Γ₀) majorX majorY
+      (.ctor ctor ctorShapes.reverse hwf))
+    (hleaf : LR.PatternLeafSpine Γ₀ (LR Γ₀) recHeadType
+      (majorX :: recXs) (majorY :: recYs)
+      ((.ctor ctor ctorShapes.reverse hwf) :: recShapes) A out outTy)
+    (hrecHead : Γ₀ ⊢ .const rec recLs : recHeadType)
+    (hout : out.HasType outTy)
+    (hA : (LR Γ₀).TyDefEq A A outTy) :
+    (LR Γ₀).DefEq
+      ((recXs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorX)
+      ((recYs.foldr (fun (a f : SExpr) => f.app a)
+        (.const rec recLs)).app majorY)
+      A out outTy := by
+  apply LRS.iotaDefEq_of_ctorExactAt hΓ hpat hmf hma hrhs leaf hleaf
+    hrecHead hout hA
+  intro rule
+  apply LRS.IotaRHSDefEq.of_nonbotWitnessResult
+    (P := fun {ρ m M} (h : LE_Interp.Witness ρ m M) =>
+      M = SExpr.mkInst recLs rule.df.rhs →
+        LR.CoherentRhsSeedAt Γ₀ Δ depth h
+          (SExpr.mkInst recLs rule.df.type)) hR
+  · intro m M hr hM
+    subst M
+    exact hP rule hr
+  · intro m m' M hle hM H hMrhs
+    exact LR.CoherentRhsSeedAt.mono (hX := hM) hle (H hMrhs)
+  · intro head mx my captureType A outTy hhead hseed _hstrong hshape
+      _htyped hspineX hspineY hcap hout hA
+    have hseed := hseed rfl
+    have hstrong : IsDefEqStrong Δ
+        (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.rhs)
+        (SExpr.mkInst recLs rule.df.type) :=
+      rule.rhsStrong recLs
+    refine producer rule mx my captureType hshape (outTyP := outTy) ?_
+    intro headTy htel hTyReg
+    cases hseed with
+    | inl hall =>
+      obtain ⟨rhsDepth, hstrat, _⟩ := hstrong.stratify
+      exact (hall rhsDepth).2 W rfl .rfl hstrong hstrat hshape htel hTyReg
+        hspineX hspineY hcap hout hA
+    | inr hlocal =>
+      exact hlocal.1.2 W rfl .rfl hstrong hlocal.2 hshape
+        htel hTyReg hspineX hspineY hcap hout hA
+
+/-- Proof-relevant semantic transport for the one non-syntax-directed case
+of stratified typing.  The output witness stays at the same shape and retains
+the recursive-result tree selected before conversion. -/
+def LE_Interp.Witness.DefeqRDeepTransport
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (Γ₀ : List SExpr) : Prop :=
+  ∀ {Γ : List SExpr} {A B : SExpr} {u : SLevel}
+      {ρ : Valuation} {a sortShape : TShape},
+    IsDefEqStrong Γ A B (.sort u) →
+    LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ →
+    Valuation.Fits Γ₀ Γ ρ →
+    ∀ (hA : LE_Interp.Witness ρ a A),
+      LE_Interp.Witness ρ sortShape (.sort u) →
+      a.HasType sortShape →
+      hA.RDeepChildren P →
+      ∃ hB : LE_Interp.Witness ρ a B, hB.RDeepChildren P
+
+/-- Proof-relevant conversion transport with the exact endpoint
+stratifications retained.
+
+The unstratified `DefeqRDeepTransport` above remains a useful generic
+isolation boundary, but it is too weak for a focused constant evaluator: a
+reverse action must attach its newly created `R` edge to the particular RHS
+typing derivation that justified the conversion.  This contract keeps both
+endpoint derivations and their common depth in scope at that construction
+point. -/
+def LE_Interp.Witness.StratifiedDefeqRDeepTransport
+    (P : ∀ {ρ m M}, LE_Interp.Witness ρ m M → Prop)
+    (Γ₀ : List SExpr) : Prop :=
+  ∀ {Γ : List SExpr} {A B : SExpr} {u : SLevel} {depth : Nat}
+      {ρ : Valuation} {a sortShape : TShape},
+    IsDefEqStrong Γ A B (.sort u) →
+    HasTypeStratifiedS Γ A (.sort u) true depth →
+    HasTypeStratifiedS Γ B (.sort u) true depth →
+    LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ →
+    Valuation.Fits Γ₀ Γ ρ →
+    ∀ (hA : LE_Interp.Witness ρ a A),
+      LE_Interp.Witness ρ sortShape (.sort u) →
+      a.HasType sortShape →
+      hA.RDeepChildren P →
+      ∃ hB : LE_Interp.Witness ρ a B, hB.RDeepChildren P
+
+/-- Every proof-independent conversion transport is a derivation-aware one
+that simply ignores the additional endpoint certificates.  The converse is
+intentionally unavailable. -/
+theorem LE_Interp.Witness.DefeqRDeepTransport.stratified
+    (H : LE_Interp.Witness.DefeqRDeepTransport P Γ₀) :
+    LE_Interp.Witness.StratifiedDefeqRDeepTransport P Γ₀ := by
+  intro Γ A B u depth ρ a sortShape hEq _hA _hB W Wfits
+    hA hSort htyped children
+  exact H hEq W Wfits hA hSort htyped children
+
+/-- Conversion transport when no consumer data is retained at evaluator
+edges. -/
+theorem LE_Interp.Witness.defeqRDeepTransport_true (Gamma0 : List SExpr) :
+    LE_Interp.Witness.DefeqRDeepTransport (fun _ => True) Gamma0 := by
+  intro Gamma A B u rho a sortShape hEq _W Wfits
+    hA _hSort _htyped _children
+  have hBpublic : LE_Interp rho a B :=
+    (LE_Interp.sound hEq Wfits).1.1 hA.toInterp
+  let hB : LE_Interp.Witness rho a B := hBpublic.witness
+  exact ⟨hB, LE_Interp.Witness.RDeepChildren.trivial hB⟩
+
+/-- Proof-relevant reverse transport for one concrete generated iota
+action at an already-typed semantic observation.
+
+The exact RHS witness is peeled before the redex is rebuilt.  Consequently
+the new constant node stores only root lowerings of the literal registered
+head witness.  Recursive provenance is attached afterward through the
+caller's depth-local seed constructor, so this theorem neither assumes nor
+manufactures a same-depth result. -/
+theorem LR.focusedIotaReverseRDeepAt
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {rec ctor : Name} {major arity : Nat}
+    {r : (RecursorIotaPattern rec major ctor arity).RHS ×
+      (RecursorIotaPattern rec major ctor arity).Check}
+    (rule : Pattern.IotaRule r)
+    {Gamma : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : (RecursorIotaPattern rec major ctor arity).Path → SExpr}
+    {A : SExpr} {rho : Valuation} {root : TShape}
+    (action : Pattern.Action Gamma r e ls capture A)
+    (hLeft : StrongSound Gamma e A)
+    (Wfits : Valuation.Fits Γ₀ Gamma rho)
+    (hRhs : LE_Interp.Witness rho root (r.1.applyS ls capture))
+    (hRhsStratified : HasTypeStratifiedS Gamma
+      (r.1.applyS ls capture) A true rhsDepth) :
+    ∃ hLeft' : LE_Interp.Witness rho root e,
+      hLeft'.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) := by
+  by_cases hbot : root ≤ TShape.bot
+  · rw [TShape.le_bot'.1 hbot]
+    exact ⟨.bot, .bot⟩
+  · let typed :=
+      ((LE_Interp.sound hRhsStratified.strong Wfits).2
+        hRhs.toInterp).outView
+    have htypedNonbot : ¬typed.termShape.T ≤ TShape.bot := by
+      intro hupper
+      exact hbot (typed.root_le.trans hupper)
+    let hRhs' : LE_Interp.Witness rho typed.termShape.T
+        (r.1.applyS ls capture) := typed.termInterp.witness
+    let view := Classical.choice <|
+      rule.focusedActionPreimage action hLeft Wfits hRhs'
+        hRhsStratified htypedNonbot
+    let hLeftUpper := view.witness Wfits hLeft
+      typed.typed.T typed.typeInterp.witness
+    exact ⟨hLeftUpper.mono typed.root_le,
+      (LR.CoherentProvenanceAt.rebuildFocused seed view hLeftUpper).mono
+        typed.root_le⟩
+
+/-- Reverse one proof-carrying local action while preserving the focused
+evaluator edge of generated iota rules.
+
+`Params.pat_simple` makes the only operational distinction needed here.
+Definition patterns have no captured application spine, so the ordinary
+guarded endpoint rebuild remains sufficient.  An iota pattern instead uses
+`focusedIotaReverseRDeepAt`, retaining the literal fixed RHS head selected by
+the source witness. -/
+theorem LR.focusedExtraReverseRDeepAt
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    {p : Pattern} {r : p.RHS × p.Check}
+    {Γ : List SExpr} {e : SExpr} {ls : List SLevel}
+    {capture : p.Path → SExpr} {A : SExpr}
+    {ρ : Valuation} {root : TShape}
+    (action : Pattern.Action Γ r e ls capture A)
+    (hLeft : IsDefEqStrong Γ e e A)
+    (hRight : IsDefEqStrong Γ (r.1.applyS ls capture)
+      (r.1.applyS ls capture) A)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ)
+    (hRhs : LE_Interp.Witness ρ root (r.1.applyS ls capture))
+    (hRhsStratified : HasTypeStratifiedS Γ
+      (r.1.applyS ls capture) A true rhsDepth) :
+    ∃ hLeft' : LE_Interp.Witness ρ root e,
+      hLeft'.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) := by
+  obtain ⟨sp, hp⟩ := Params.pat_simple action.pat
+  cases sp with
+  | defn c =>
+    have hLeftPublic : LE_Interp ρ root e :=
+      (LE_Interp.sound (.extra action hLeft hRight) Wfits).1.2
+        hRhs.toInterp
+    let hLeft' : LE_Interp.Witness ρ root e := hLeftPublic.witness
+    exact ⟨hLeft', LR.CoherentProvenanceAt.rebuild seed⟩
+  | iota rec major ctor arity =>
+    subst p
+    exact LR.focusedIotaReverseRDeepAt seed
+      (Params.Semantic.iotaRule action.pat) action
+      (LE_Interp.strongSound hLeft).left Wfits hRhs
+      hRhsStratified
+
+/-- Guarded transport used for equality constructors that do not expose a
+more precise structural action.
+
+Both endpoint witnesses are selected at the caller's already-smaller local
+depth.  Their trees are rebuilt from the endpoint's own evaluator structure,
+while focused action traces present in the source tree are replayed only at
+recursive edges with the same syntax.  This is intentionally a bidirectional
+package so `symm` and `trans` can be interpreted structurally without losing
+a nested iota action. -/
+private theorem LR.coherentDefeqRDeepFallbackPairAt
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    (hEq : IsDefEqStrong Γ A B T)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ) :
+    (∀ (hA : LE_Interp.Witness ρ root A),
+      hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+      ∃ hB : LE_Interp.Witness ρ root B,
+        hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) ∧
+    (∀ (hB : LE_Interp.Witness ρ root B),
+      hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+      ∃ hA : LE_Interp.Witness ρ root A,
+        hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) := by
+  by_cases hsyntax : A = B
+  · subst B
+    exact ⟨fun hA children => ⟨hA, children⟩,
+      fun hA children => ⟨hA, children⟩⟩
+  · constructor
+    · intro hA children
+      have hBpublic : LE_Interp ρ root B :=
+        (LE_Interp.sound hEq Wfits).1.1 hA.toInterp
+      let hB : LE_Interp.Witness ρ root B := hBpublic.witness
+      exact ⟨hB,
+        LR.CoherentProvenanceAt.rebuildTracingFocused seed children⟩
+    · intro hB children
+      have hApublic : LE_Interp ρ root A :=
+        (LE_Interp.sound hEq Wfits).1.2 hB.toInterp
+      let hA : LE_Interp.Witness ρ root A := hApublic.witness
+      exact ⟨hA,
+        LR.CoherentProvenanceAt.rebuildTracingFocused seed children⟩
 
-/-- Main adequacy theorem for the logical relation. -/
-theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
+/-- Bidirectional, derivation-aware transport for displayed-type equality.
+
+Symmetry swaps the two continuations and transitivity composes them.  This
+ensures an iota action remains visible even when it is nested below either
+constructor.  Syntax-directed application and binder constructors transport
+their exact subtrees.  Remaining constructors use the guarded local rebuild,
+which replays focused traces at matching recursive-edge syntax; the reverse
+branch of `extra` additionally dispatches generated iota patterns to the
+focused evaluator. -/
+private theorem LR.coherentDefeqRDeepPairAt
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    (hEq : IsDefEqStrong Γ A B T)
+    (hAStratified : HasTypeStratifiedS Γ A T true leftDepth)
+    (hBStratified : HasTypeStratifiedS Γ B T true rightDepth)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ) :
+    (∀ (hA : LE_Interp.Witness ρ root A),
+      hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+      ∃ hB : LE_Interp.Witness ρ root B,
+        hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) ∧
+    (∀ (hB : LE_Interp.Witness ρ root B),
+      hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+      ∃ hA : LE_Interp.Witness ρ root A,
+        hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) := by
+  let rec go {Γ A B T} (hEq : IsDefEqStrong Γ A B T)
+      {leftDepth rightDepth : Nat}
+      (hAStratified : HasTypeStratifiedS Γ A T true leftDepth)
+      (hBStratified : HasTypeStratifiedS Γ B T true rightDepth)
+      {ρ root}
+      (Wfits : Valuation.Fits Γ₀ Γ ρ) :
+      (∀ (hA : LE_Interp.Witness ρ root A),
+        hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+        ∃ hB : LE_Interp.Witness ρ root B,
+          hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) ∧
+      (∀ (hB : LE_Interp.Witness ρ root B),
+        hB.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth) →
+        ∃ hA : LE_Interp.Witness ρ root A,
+          hA.RDeepChildren (LR.CoherentProvenanceAt Γ₀ depth)) :=
+    match hEq with
+    | .symm h =>
+      let ih := go h hBStratified hAStratified Wfits
+      ⟨ih.2, ih.1⟩
+    | .trans h₁ h₂ =>
+      let hMid := Classical.choose (h₁.stratify)
+      let hMidStratified := (Classical.choose_spec (h₁.stratify)).2
+      let ih₁ := go h₁ hAStratified hMidStratified Wfits
+      let ih₂ := go h₂ hMidStratified hBStratified Wfits
+      ⟨fun hA children => by
+          obtain ⟨hMid, midChildren⟩ := ih₁.1 hA children
+          exact ih₂.1 hMid midChildren,
+        fun hB children => by
+          obtain ⟨hMid, midChildren⟩ := ih₂.2 hB children
+          exact ih₁.2 hMid midChildren⟩
+    | .appDF _ _ hf ha _ => by
+      obtain ⟨_, hfLeft, hfRight⟩ := hf.stratify
+      obtain ⟨_, haLeft, haRight⟩ := ha.stratify
+      constructor
+      · intro hApp children
+        cases hApp with
+        | bot => exact ⟨.bot, .bot⟩
+        | app hFun hArg hle =>
+          cases children with
+          | app cFun cArg =>
+            obtain ⟨hFun', cFun'⟩ :=
+              (go hf hfLeft hfRight Wfits).1 hFun cFun
+            obtain ⟨hArg', cArg'⟩ :=
+              (go ha haLeft haRight Wfits).1 hArg cArg
+            exact ⟨.app hFun' hArg' hle, .app cFun' cArg'⟩
+      · intro hApp children
+        cases hApp with
+        | bot => exact ⟨.bot, .bot⟩
+        | app hFun hArg hle =>
+          cases children with
+          | app cFun cArg =>
+            obtain ⟨hFun', cFun'⟩ :=
+              (go hf hfLeft hfRight Wfits).2 hFun cFun
+            obtain ⟨hArg', cArg'⟩ :=
+              (go ha haLeft haRight Wfits).2 hArg cArg
+            exact ⟨.app hFun' hArg' hle, .app cFun' cArg'⟩
+    | @IsDefEqStrong.lamDF _ _ Dom Dom' _ _ _ _ _
+        hDom _ _ hBody hBody' => by
+      obtain ⟨_, hDomLeft, hDomRight⟩ := hDom.stratify
+      obtain ⟨_, hBodyLeft, hBodyRight⟩ := hBody.stratify
+      obtain ⟨_, hBodyLeft', hBodyRight'⟩ := hBody'.stratify
+      have fitTypeLeft : ∀ {a}, LE_Interp ρ a Dom →
+          ∃ a', a ≤ a' ∧ LE_Interp ρ a' Dom ∧ a'.HasType .type := by
+        intro a hA
+        exact InterpTyped.hsort
+          (fun hA' => (LE_Interp.sound hDom Wfits).2 hA') hA
+      have fitTypeRight : ∀ {a}, LE_Interp ρ a Dom' →
+          ∃ a', a ≤ a' ∧ LE_Interp ρ a' Dom' ∧ a'.HasType .type := by
+        intro a hA
+        exact InterpTyped.hsort
+          (fun hA' => (LE_Interp.sound hDom.symm Wfits).2 hA') hA
+      constructor
+      · intro hLam children
+        cases hLam with
+        | bot => exact ⟨.bot, .bot⟩
+        | lam hDom₁ hshape hbody hle =>
+          cases children with
+          | lam cDom₁ cbody =>
+            obtain ⟨hDom₁', cDom₁'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).1 hDom₁ cDom₁
+            let transported := fun x (hx : x.HasType _) =>
+              (go hBody hBodyLeft hBodyRight
+                (Wfits.cons fitTypeLeft hDom₁.toInterp hx.T)).1
+                (hbody x hx) (cbody x hx)
+            let hbody' := fun x hx => Classical.choose (transported x hx)
+            have cbody' : ∀ x hx,
+                (hbody' x hx).RDeepChildren
+                  (LR.CoherentProvenanceAt Γ₀ depth) :=
+              fun x hx => Classical.choose_spec (transported x hx)
+            exact ⟨.lam hDom₁' hshape hbody' hle,
+              .lam cDom₁' cbody'⟩
+      · intro hLam children
+        cases hLam with
+        | bot => exact ⟨.bot, .bot⟩
+        | lam hDom₁ hshape hbody hle =>
+          cases children with
+          | lam cDom₁ cbody =>
+            obtain ⟨hDom₁', cDom₁'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).2 hDom₁ cDom₁
+            let transported := fun x (hx : x.HasType _) =>
+              (go hBody' hBodyLeft' hBodyRight'
+                (Wfits.cons fitTypeRight hDom₁.toInterp hx.T)).2
+                (hbody x hx) (cbody x hx)
+            let hbody' := fun x hx => Classical.choose (transported x hx)
+            have cbody' : ∀ x hx,
+                (hbody' x hx).RDeepChildren
+                  (LR.CoherentProvenanceAt Γ₀ depth) :=
+              fun x hx => Classical.choose_spec (transported x hx)
+            exact ⟨.lam hDom₁' hshape hbody' hle,
+              .lam cDom₁' cbody'⟩
+    | @IsDefEqStrong.forallEDF _ _ Dom Dom' _ _ _ _
+        hDom hBody hBody' => by
+      obtain ⟨_, hDomLeft, hDomRight⟩ := hDom.stratify
+      obtain ⟨_, hBodyLeft, hBodyRight⟩ := hBody.stratify
+      obtain ⟨_, hBodyLeft', hBodyRight'⟩ := hBody'.stratify
+      have fitTypeLeft : ∀ {a}, LE_Interp ρ a Dom →
+          ∃ a', a ≤ a' ∧ LE_Interp ρ a' Dom ∧ a'.HasType .type := by
+        intro a hA
+        exact InterpTyped.hsort
+          (fun hA' => (LE_Interp.sound hDom Wfits).2 hA') hA
+      have fitTypeRight : ∀ {a}, LE_Interp ρ a Dom' →
+          ∃ a', a ≤ a' ∧ LE_Interp ρ a' Dom' ∧ a'.HasType .type := by
+        intro a hA
+        exact InterpTyped.hsort
+          (fun hA' => (LE_Interp.sound hDom.symm Wfits).2 hA') hA
+      constructor
+      · intro hPi children
+        cases hPi with
+        | bot => exact ⟨.bot, .bot⟩
+        | forallE hDom₁ hDom₂ hshape hbody hle =>
+          cases children with
+          | forallE cDom₁ cDom₂ cbody =>
+            obtain ⟨hDom₁', cDom₁'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).1 hDom₁ cDom₁
+            obtain ⟨hDom₂', cDom₂'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).1 hDom₂ cDom₂
+            let transported := fun x (hx : x.HasType _) =>
+              (go hBody hBodyLeft hBodyRight
+                (Wfits.cons fitTypeLeft hDom₂.toInterp hx.T)).1
+                (hbody x hx) (cbody x hx)
+            let hbody' := fun x hx => Classical.choose (transported x hx)
+            have cbody' : ∀ x hx,
+                (hbody' x hx).RDeepChildren
+                  (LR.CoherentProvenanceAt Γ₀ depth) :=
+              fun x hx => Classical.choose_spec (transported x hx)
+            exact ⟨.forallE hDom₁' hDom₂' hshape hbody' hle,
+              .forallE cDom₁' cDom₂' cbody'⟩
+      · intro hPi children
+        cases hPi with
+        | bot => exact ⟨.bot, .bot⟩
+        | forallE hDom₁ hDom₂ hshape hbody hle =>
+          cases children with
+          | forallE cDom₁ cDom₂ cbody =>
+            obtain ⟨hDom₁', cDom₁'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).2 hDom₁ cDom₁
+            obtain ⟨hDom₂', cDom₂'⟩ :=
+              (go hDom hDomLeft hDomRight Wfits).2 hDom₂ cDom₂
+            let transported := fun x (hx : x.HasType _) =>
+              (go hBody' hBodyLeft' hBodyRight'
+                (Wfits.cons fitTypeRight hDom₂.toInterp hx.T)).2
+                (hbody x hx) (cbody x hx)
+            let hbody' := fun x hx => Classical.choose (transported x hx)
+            have cbody' : ∀ x hx,
+                (hbody' x hx).RDeepChildren
+                  (LR.CoherentProvenanceAt Γ₀ depth) :=
+              fun x hx => Classical.choose_spec (transported x hx)
+            exact ⟨.forallE hDom₁' hDom₂' hshape hbody' hle,
+              .forallE cDom₁' cDom₂' cbody'⟩
+    | .defeqDF _ h => by
+      obtain ⟨_, hLeft, hRight⟩ := h.stratify
+      exact go h hLeft hRight Wfits
+    | h@(.beta _ _ _ _) => by
+      constructor
+      · intro hRedex children
+        cases hRedex with
+        | bot => exact ⟨.bot, .bot⟩
+        | @app _ _ f _ _ _ _ hLam hArg hroot =>
+          cases children with
+          | app cLam cArg =>
+            cases f using WShape.casesOn' with
+            | @lam g hg =>
+              obtain ⟨hInst, cInst⟩ := cLam.lam_inst
+                LE_Interp.Witness.TransportClosure.laws.mono_l
+                LE_Interp.Witness.TransportClosure.laws.closed cArg
+              exact ⟨hInst.mono hroot, cInst.mono hroot⟩
+            | _ =>
+              have hrootBot : root ≤ TShape.bot :=
+                hroot.trans TShape.bot_le'
+              rw [TShape.le_bot'.1 hrootBot]
+              exact ⟨.bot, .bot⟩
+      · exact (LR.coherentDefeqRDeepFallbackPairAt
+          (root := root) seed h Wfits).2
+    | .proofIrrel hProp hLeft hRight => by
+      have collapses
+          {term : SExpr}
+          (hTerm : IsDefEqStrong Γ term term T)
+          (hTermWitness : LE_Interp.Witness ρ root term) :
+          root ≤ TShape.bot := by
+        obtain ⟨termUpper, typeUpper, hroot, _hTermUpper,
+            hTypeUpper, htyped⟩ :=
+          (LE_Interp.sound hTerm Wfits).2 hTermWitness.toInterp
+        obtain ⟨typeUpper', sortUpper, htype,
+            _hTypeUpper', hSortUpper, htypeTyped⟩ :=
+          (LE_Interp.sound hProp Wfits).2 hTypeUpper
+        have htypeProp : typeUpper'.HasType (.sort false) :=
+          TShape.HasType.mono_r (by simpa using hSortUpper.le_sort)
+            .sort htypeTyped
+        exact hroot.trans <|
+          htypeProp.proofIrrel (htypeProp.mono_r htype htyped)
+      constructor
+      · intro hTerm _children
+        rw [TShape.le_bot'.1 (collapses hLeft hTerm)]
+        exact ⟨.bot, .bot⟩
+      · intro hTerm _children
+        rw [TShape.le_bot'.1 (collapses hRight hTerm)]
+        exact ⟨.bot, .bot⟩
+    | .extra action hLeft hRight =>
+      let fallback := LR.coherentDefeqRDeepFallbackPairAt seed
+        (.extra action hLeft hRight) Wfits
+      ⟨fallback.1, fun hRhs _children =>
+        LR.focusedExtraReverseRDeepAt seed action hLeft hRight
+          Wfits hRhs hBStratified⟩
+    | h => LR.coherentDefeqRDeepFallbackPairAt seed h Wfits
+  exact go hEq hAStratified hBStratified Wfits
+
+/-- Exact conversion transport justified by a depth-local seed constructor.
+
+The strong equality is traversed through `symm` and `trans`, so a reverse
+generated-iota action is handled by the focused evaluator even when nested
+under those constructors.  Other branches select an endpoint by semantic
+soundness and rebuild its tree only with the caller's local seed.  Thus a
+reverse iota edge remains pinned to its literal RHS head, while every fresh
+tree is still guarded by the already-complete smaller-depth callback. -/
+theorem LR.coherentDefeqRDeepTransportAt
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth) :
+    LE_Interp.Witness.StratifiedDefeqRDeepTransport
+      (LR.CoherentProvenanceAt Γ₀ depth) Γ₀ := by
+  intro Γ A B u endpointDepth ρ a sortShape hEq hAStratified
+    hBStratified _W Wfits
+    hA _hSort _htyped children
+  exact (LR.coherentDefeqRDeepPairAt seed hEq hAStratified
+    hBStratified Wfits).1 hA children
+
+/-- Retained semantic typing from syntax recursion plus exact conversion
+transport.
+
+Binder validity uses ordinary semantic typing of the stratified domain; it
+does not restart the retained consumer on an unrelated witness.  Thus the
+only provenance-sensitive input is `convert`, and no Nat-first callback is
+needed. -/
+theorem LE_Interp.Witness.typedRDeep_of_stratifiedWith
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (convert : LE_Interp.Witness.StratifiedDefeqRDeepTransport P Γ₀)
+    (H : HasTypeStratifiedS Γ M A core depth)
+    (W : LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ)
+    (hM : LE_Interp.Witness ρ m M)
+    (childrenP : hM.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m M A := by
+  induction H generalizing ρ m with
+  | base _ ih => exact ih W Wfits hM childrenP
+  | @sort' Γ l depth =>
+    let tm := TShape.sort (decide (l ≠ .zero))
+    let ty := TShape.type
+    let hterm : LE_Interp.Witness ρ tm (.sort l) := .sort .rfl
+    let htype : LE_Interp.Witness ρ ty (.sort l.succ) :=
+      .sort (by simpa [ty, TShape.type] using
+        (TShape.LE.rfl : TShape.sort true ≤ TShape.sort true))
+    exact ⟨tm, ty, hterm, htype, hM.toInterp.le_sort,
+      .sort, .sort, .sort⟩
+  | @bvar Γ i A u depth hlookup hA ihA =>
+    have hle := LE_Interp.bvar_iff.1 hM.toInterp
+    exact (W.lookup laws hlookup).mono hle
+  | @const c ci Γ ls u depth hreg hlen hTy ihTy =>
+    cases hM with
+    | bot => exact .bot TShape.bot_eqv.1
+    | @const _ _ ci' _ m' _ a' _ R hreg' hlen' hle hty hA hC hR =>
+      cases hreg.symm.trans hreg'
+      cases childrenP with
+      | const cA pR cR =>
+        let hconst : LE_Interp.Witness ρ m' (.const c ls) :=
+          .const hreg hlen .rfl hty hA hC hR
+        exact ⟨m', a', hconst, hA, hle, hty,
+          .const cA pR cR, cA⟩
+  | @app Γ A u depth B v f a hA hCod hf ha hResult
+      ihA ihCod ihf iha ihResult =>
+    exact LE_Interp.Witness.TypedRDeep.app
+      (F := f) (A := A) (B := B) (X := a)
+      laws.mono_l laws.closed
+      (H1 := fun hF cF => ihf W Wfits hF cF)
+      (H2 := fun hB cB => (ihResult W Wfits hB cB).toType)
+      childrenP
+  | @lam Γ A u depth B v body hA hB hbody hPi
+      ihA ihB ihbody ihPi =>
+    have fitType : ∀ {a}, LE_Interp ρ a A →
+        ∃ a', a ≤ a' ∧ LE_Interp ρ a' A ∧ a'.HasType .type := by
+      intro a ha
+      exact InterpTyped.hsort
+        (fun hAsem => (LE_Interp.sound hA.strong Wfits).2 hAsem) ha
+    exact LE_Interp.Witness.TypedRDeep.lam laws
+      (H2 := fun {a x} hDom cDom hx {e} hBody cBody =>
+        ihbody
+          (W.push (ihA W Wfits hDom cDom).toType hx)
+          (Wfits.cons fitType hDom.toInterp hx) hBody cBody)
+      childrenP
+  | @forallE Γ A u depth body v hA hbody ihA ihbody =>
+    have fitType : ∀ {a}, LE_Interp ρ a A →
+        ∃ a', a ≤ a' ∧ LE_Interp ρ a' A ∧ a'.HasType .type := by
+      intro a ha
+      exact InterpTyped.hsort
+        (fun hAsem => (LE_Interp.sound hA.strong Wfits).2 hAsem) ha
+    exact LE_Interp.Witness.TypedRDeep.forallE laws
+      (H1 := fun hDom cDom => ihA W Wfits hDom cDom)
+      (H2 := fun {a x} hDom cDom hx {e} hBody cBody =>
+        ihbody
+          (W.push (ihA W Wfits hDom cDom).toType hx)
+          (Wfits.cons fitType hDom.toInterp hx) hBody cBody)
+      childrenP
+  | @defeq Γ A B u depth e hEq hA hB he ihA ihB ihe =>
+    obtain ⟨tm, a, he', hA', hle, htyped, ce, cA⟩ :=
+      ihe W Wfits hM childrenP
+    obtain ⟨a', sortShape, hA'', hSort, ha, haTyped, cA', _cSort⟩ :=
+      ihA W Wfits hA' cA
+    obtain ⟨hB', cB⟩ :=
+      convert hEq hA hB W Wfits hA'' hSort haTyped cA'
+    exact ⟨tm, a, he', hB'.mono ha, hle, htyped, ce, cB.mono ha⟩
+
+/-- Compatibility entry point for consumers whose conversion invariant does
+not depend on the endpoint derivations. -/
+theorem LE_Interp.Witness.typedRDeep_of_stratified
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (convert : LE_Interp.Witness.DefeqRDeepTransport P Γ₀)
+    (H : HasTypeStratifiedS Γ M A core depth)
+    (W : LE_Interp.Witness.FitsRDeep P Γ₀ Γ ρ)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ)
+    (hM : LE_Interp.Witness ρ m M)
+    (childrenP : hM.RDeepChildren P) :
+    LE_Interp.Witness.TypedRDeep P ρ m M A :=
+  LE_Interp.Witness.typedRDeep_of_stratifiedWith laws
+    convert.stratified H W Wfits hM childrenP
+
+/-- Retained semantic typing at a local provenance depth.
+
+The only non-syntax-directed branch is discharged by rebuilding the
+converted endpoint tree with `seed`.  This specialization is the admissible
+replacement for assuming a global, arbitrary-predicate
+`DefeqRDeepTransport`. -/
+theorem LE_Interp.Witness.typedRDeep_of_stratifiedLocal
+    (seed : ∀ {ρ root X} (hX : LE_Interp.Witness ρ root X),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+        LR.CoherentRetainedAt Γ₀ hX depth)
+    (H : HasTypeStratifiedS Γ M A core depth)
+    (W : LE_Interp.Witness.FitsRDeep
+      (LR.CoherentProvenanceAt Γ₀ depth) Γ₀ Γ ρ)
+    (Wfits : Valuation.Fits Γ₀ Γ ρ)
+    (hM : LE_Interp.Witness ρ m M)
+    (children : hM.RDeepChildren
+      (LR.CoherentProvenanceAt Γ₀ depth)) :
+    LE_Interp.Witness.TypedRDeep
+      (LR.CoherentProvenanceAt Γ₀ depth) ρ m M A := by
+  exact LE_Interp.Witness.typedRDeep_of_stratifiedWith
+    LE_Interp.Witness.TransportClosure.laws
+    (LR.coherentDefeqRDeepTransportAt seed)
+    H W Wfits hM children
+
+/-- Package the direct retained-typing theorem at one exact stratification
+depth. -/
+theorem LE_Interp.Witness.soundRDeepAt_of_defeqTransport
+    (laws : LE_Interp.Witness.RDeepChildren.Laws P)
+    (convert : LE_Interp.Witness.DefeqRDeepTransport P Γ₀)
+    {hM : LE_Interp.Witness ρ m M}
+    (childrenP : hM.RDeepChildren P) (depth : Nat) :
+    LE_Interp.Witness.SoundRDeepAt P Γ₀ hM depth := by
+  intro Γ A core H W Wfits
+  exact LE_Interp.Witness.typedRDeep_of_stratified
+    laws convert H W Wfits hM childrenP
+
+/-- Every exact witness has retained semantic typing when evaluator edges
+carry only `True`. -/
+theorem LE_Interp.Witness.soundRDeepAt_true
+    (hM : LE_Interp.Witness rho m M) (depth : Nat) :
+    LE_Interp.Witness.SoundRDeepAt (fun _ => True) Gamma0 hM depth :=
+  LE_Interp.Witness.soundRDeepAt_of_defeqTransport
+    LE_Interp.Witness.RDeepChildren.Laws.true
+    (LE_Interp.Witness.defeqRDeepTransport_true Gamma0)
+    (LE_Interp.Witness.RDeepChildren.trivial hM) depth
+
+/-- The direct constant producer left by the syntax-directed self-adequacy
+algebra.
+
+The recursive edge tree deliberately retains `CoherentSeedAt`: a constant
+case may select a registered RHS while it still needs to distinguish a
+genuine all-depth evaluator child from a depth-local rebuilt child.  A
+strictly smaller restart likewise requires the exact rebuilt tree before it
+may return a local coherent result. -/
+def LR.SelfAdequateConstStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {Γ : List SExpr}
+      {ls : List SLevel} {u : SLevel} {depth : Nat}
+      {ρ : Valuation} {n : Nat} {mx bx : WShape n},
+    Params.env.constants c = some ci →
+    ls.length = ci.uvars →
+    HasTypeStratifiedS Γ (SExpr.mkInst ls ci.type)
+      (.sort u) true depth →
+    (∀ (d' : Nat), d' < depth + 1 →
+      ∀ {ρ root X} (hX' : LE_Interp.Witness ρ root X),
+        hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX' d') →
+    mx.HasType bx →
+    LE_Interp.Witness ρ bx.T (SExpr.mkInst ls ci.type) →
+    ∀ (hX : LE_Interp.Witness ρ mx.T (.const c ls)),
+      hX.RDeepChildren (LR.CoherentSeedAt Γ₀ (depth + 1)) →
+      LR.Adequate Γ₀ Γ ρ (.const c ls) (.const c ls)
+        (SExpr.mkInst ls ci.type) mx bx
+
+/-- The conversion case of depth-indexed self-adequacy.
+
+The source type certificate is strictly shallower than `outerDepth`.  The
+current compatibility construction discharges this callback from completed
+stratified inversion; the depth fixpoint instead discharges it directly from
+heterogeneous adequacy at that smaller certificate depth. -/
+def LR.SelfAdequateDefeqStepAt
+    (Γ₀ : List SExpr) (outerDepth : Nat) : Prop :=
+  ∀ {Γ : List SExpr} {A B e : SExpr} {u : SLevel} {depth : Nat}
+      {ρ : Valuation} {n : Nat} {m b : WShape n},
+    depth < outerDepth →
+    HasTypeStratifiedS Γ A (.sort u) true depth →
+    IsDefEqStrong Γ A B (.sort u) →
+    LE_Interp ρ m.T e → LE_Interp ρ b.T B → m.HasType b →
+    (∀ {n'} {ma sa : WShape n'},
+      LE_Interp ρ ma.T A → LE_Interp ρ sa.T (.sort u) →
+      ma.HasType sa → LR.Adequate Γ₀ Γ ρ A A (.sort u) ma sa) →
+    (∀ {n'} {mb sb : WShape n'},
+      LE_Interp ρ mb.T B → LE_Interp ρ sb.T (.sort u) →
+      mb.HasType sb → LR.Adequate Γ₀ Γ ρ B B (.sort u) mb sb) →
+    (∀ {n'} {me ae : WShape n'},
+      LE_Interp ρ me.T e → LE_Interp ρ ae.T A →
+      me.HasType ae → LR.Adequate Γ₀ Γ ρ e e A me ae) →
+    LR.Adequate Γ₀ Γ ρ e e B m b
+
+/-- Compatibility implementation of the conversion callback from the
+already-complete inversion package. -/
+theorem LR.SelfAdequateDefeqStepAt.of_stratifiedInversion
+    (inv : JointStratifiedInversion) (hΓ₀ : Ctx.WF Γ₀)
+    (outerDepth : Nat) :
+    LR.SelfAdequateDefeqStepAt Γ₀ outerDepth := by
+  intro Γ A B e u depth ρ n m b _ _ hEq hM hB hmem ihA ihB ihe
+  exact LR.adequateDefeqSelf_of_stratifiedInversion inv hΓ₀ hEq
+    hM hB hmem ihA ihB ihe
+
+/-- Well-founded implementation of the conversion callback from strictly
+smaller depth-bounded adequacy.  This is the handoff used by the new depth
+fixpoint; no inversion or path collapse is involved. -/
+theorem LR.SelfAdequateDefeqStepAt.of_lowerAdequacy
+    (hΓ₀ : Ctx.WF Γ₀) (outerDepth : Nat)
+    (lowerAdequacy : ∀ d, d < outerDepth →
+      LR.ContextualAdequacyAtDepth d) :
+    LR.SelfAdequateDefeqStepAt Γ₀ outerDepth := by
+  intro Γ A B e u depth ρ n m b hdepth hAty hEq hM hB hmem _ _ ihe
+  apply LR.adequateDefeq hEq hM hB hmem
+  · intro n' ma sa hA hSort hma
+    exact (lowerAdequacy depth hdepth hΓ₀)
+      hEq hAty hA hSort hma
+  · exact ihe
+
+/-- Every non-constant stratified typing constructor preserves retained
+self-adequacy. The constant constructor is deliberately exposed as the
+separate producer contract above. -/
+private theorem LR.selfAdequateExactAtStep
+    (outerDepth : Nat)
+    (defeqStep : LR.SelfAdequateDefeqStepAt Γ₀ outerDepth)
+    (hΓ₀ : Ctx.WF Γ₀)
+    (constStep : LR.SelfAdequateConstStep Γ₀)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X)
+    (children : hX.RDeepChildren (LR.CoherentSeedAt Γ₀ outerDepth))
+    (lower : ∀ (d' : Nat), d' < outerDepth → ∀ {ρ root X}
+      (hX' : LE_Interp.Witness ρ root X),
+      hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+      LR.CoherentRetainedAt Γ₀ hX' d') :
+    LR.SelfAdequateExactAt Γ₀ hX outerDepth := by
+  intro n mx bx Δ core B hroot hTyping htyped hB
+  subst root
+  have restartSelf : ∀ (d' : Nat), d' < outerDepth →
+      ∀ {ρ root X} (hX' : LE_Interp.Witness ρ root X),
+        LR.SelfAdequateAt Γ₀ hX' d' := by
+    intro d' hdepth ρ root X hX'
+    exact (LR.CoherentRetainedAt.restart
+      (lower := lower) hdepth (hX := hX')).1
+  induction hTyping generalizing ρ n mx bx with
+  | base htypedCore ih =>
+    exact ih defeqStep lower htyped hB hX children restartSelf
+  | @sort' Δ l depth =>
+    suffices (LR Γ₀).DefEq (.sort l) (.sort l) (.sort l.succ) mx bx from
+      ⟨fun _ _ _ => ⟨this, this⟩, fun _ _ => this⟩
+    cases htyped.unfold with
+    | bot hm => exact (LR _).bot hm
+    | sort => exact (LR _).sort_iff.2 ⟨_, .rfl, .rfl⟩
+    | _ =>
+      obtain h | h := WShape.le_sort.1 hX.toInterp.le_sort'
+      · dsimp only at h
+        rw [h]
+        exact (LR _).bot htyped.isType
+      · simp [WShape.ext_iff, WShape.forallE, WShape.sort, Shape.sort,
+          WShape.lam', WShape.lam, WShape.bot, WShape.ctor, WShape.indTy,
+          Shape.bot] at h <;>
+          first
+          | split at h <;> simp_all only [reduceCtorEq]
+          | simp_all
+  | @bvar Δ i A u depth hlookup hA ihA =>
+    refine .refl fun _ _ W => ?_
+    have hle := LE_Interp.bvar_iff.1 hX.toInterp
+    clear hX children ihA hA
+    induction W generalizing i A with
+    | id =>
+      cases show mx = .bot from TShape.le_bot.1 (hle.trans TShape.bot_le)
+      exact (LR _).bot htyped.isType
+    | cons W' _ _ _ _ h0 ih =>
+      cases hlookup with
+      | zero =>
+        exact lift_subst ▸ (h0.2 bx hB.toInterp).2 (.bvar hle) htyped
+      | succ h' => exact lift_subst ▸ ih h' hB.unweak hle
+  | @const c ci Γ ls u depth hreg hlen hTy _ =>
+    exact constStep hreg hlen hTy lower htyped hB hX children
+  | @app Γ A u depth B v f x hAty hBty hfty hxty hRty
+      _ _ _ _ _ =>
+    have hdepth : depth < depth + 1 := Nat.lt_succ_self depth
+    have ihf : ∀ {ρ : Valuation} {n' : Nat} {mf af : WShape n'},
+        LE_Interp ρ mf.T f → LE_Interp ρ af.T (.forallE A B) →
+        mf.HasType af →
+        LR.Adequate Γ₀ Γ ρ f f (.forallE A B) mf af := by
+      intro ρ n' mf af hf hPi hmf
+      let whf := hf.witness
+      let whPi := hPi.witness
+      exact (restartSelf depth hdepth whf) .rfl hfty hmf whPi
+    have ihx : ∀ {ρ : Valuation} {n' : Nat} {ma aa : WShape n'},
+        LE_Interp ρ ma.T x → LE_Interp ρ aa.T A →
+        ma.HasType aa → LR.Adequate Γ₀ Γ ρ x x A ma aa := by
+      intro ρ n' ma aa hx hA hma
+      let whx := hx.witness
+      let whA := hA.witness
+      exact (restartSelf depth hdepth whx) .rfl hxty hma whA
+    have ihR : ∀ {ρ : Valuation} {n' : Nat} {mb av : WShape n'},
+        LE_Interp ρ mb.T (B.inst x) → LE_Interp ρ av.T (.sort v) →
+        mb.HasType av →
+        LR.Adequate Γ₀ Γ ρ (B.inst x) (B.inst x) (.sort v) mb av := by
+      intro ρ n' mb av hResult hv hmb
+      let whResult := hResult.witness
+      let whv := hv.witness
+      exact (restartSelf depth hdepth whResult) .rfl hRty hmb whv
+    exact LR.adequateApp hfty.strong hxty.strong hRty.strong
+      hX.toInterp hB.toInterp htyped ihf ihx ihR
+  | @lam Γ A u depth B v body hAty hBty hbodyty hPity
+      _ _ _ _ =>
+    let HA := hAty.strong
+    let HB := hBty.strong
+    let HBody := hbodyty.strong
+    have hdepth : depth < depth + 1 := Nat.lt_succ_self depth
+    have ihA : ∀ {ρ : Valuation} {n' : Nat} {ma aa : WShape n'},
+        LE_Interp ρ ma.T A → LE_Interp ρ aa.T (.sort u) →
+        ma.HasType aa → LR.Adequate Γ₀ Γ ρ A A (.sort u) ma aa := by
+      intro ρ n' ma aa hA hSort hma
+      exact (restartSelf depth hdepth hA.witness)
+        .rfl hAty hma hSort.witness
+    have ihB : ∀ {ρ : Valuation} {n' : Nat} {mb ab : WShape n'},
+        LE_Interp ρ mb.T B → LE_Interp ρ ab.T (.sort v) →
+        mb.HasType ab →
+        LR.Adequate Γ₀ (A :: Γ) ρ B B (.sort v) mb ab := by
+      intro ρ n' mb ab hB hSort hmb
+      exact (restartSelf depth hdepth hB.witness)
+        .rfl hBty hmb hSort.witness
+    have ihBody : ∀ {ρ : Valuation} {n' : Nat} {mb ab : WShape n'},
+        LE_Interp ρ mb.T body → LE_Interp ρ ab.T B →
+        mb.HasType ab →
+        LR.Adequate Γ₀ (A :: Γ) ρ body body B mb ab := by
+      intro ρ n' mb ab hbody hB hmb
+      exact (restartSelf depth hdepth hbody.witness)
+        .rfl hbodyty hmb hB.witness
+    have hTerm := hX.toInterp
+    have hPi := hB.toInterp
+    suffices ∀ {X Y X' Y' σ σ'},
+        LE_Interp ρ mx.T (.lam X Y) → LR.SubstWF Γ₀ σ σ' Γ ρ →
+        (∀ {k np} {p : WShape np} {mb ab : WShape k},
+          (ρ.push p.T).Fits Γ₀ (A :: Γ) →
+          LE_Interp (ρ.push p.T) mb.T Y →
+          LE_Interp (ρ.push p.T) ab.T B → mb.HasType ab →
+          LR.Adequate Γ₀ (A :: Γ) (ρ.push p.T) Y Y' B mb ab) →
+        (LR Γ₀).DefEq (.subst (.lam X Y) σ)
+          (.subst (.lam X' Y') σ') (.subst (.forallE A B) σ) mx bx by
+      refine ⟨fun σ σ' W => ⟨?_, ?_⟩,
+        fun σ W => this hTerm W fun _ => ihBody⟩
+      · exact this hTerm W
+          fun _ hMb hBb hmb => (ihBody hMb hBb hmb).left
+      · refine this ?_ W fun W hMb' hBb hmb => ?_
+        · exact (LE_Interp.sound
+            (.lamDF HA HB HB HBody HBody) W.fits).1.1 hTerm
+        · exact (ihBody
+            ((LE_Interp.sound HBody W).1.2 hMb') hBb hmb).symm.left
+    intro X Y X' Y' σ σ' hTerm' W IH
+    suffices ∀ n' b (fshape : WShapeFun _), n = n' + 1 →
+        bx ≍ (.forallE b fshape : WShape (n' + 1)) →
+        (LR Γ₀).DefEq (.subst (.lam X Y) σ)
+          (.subst (.lam X' Y') σ') (.subst (.forallE A B) σ) mx bx by
+      cases htyped.unfold with
+      | bot hm =>
+        cases hm.unfold with
+        | bot | sort => cases n <;> trivial
+        | indTy => trivial
+        | forallE => exact this _ _ _ rfl .rfl
+      | sort =>
+        cases n <;> let .lam _ _ _ h := hTerm' <;>
+          cases TShape.sort_not_le_lam' h
+      | forallE =>
+        let .lam _ _ _ h := hTerm'
+        cases TShape.forallE_not_le_lam' h
+      | lam => exact this _ _ _ rfl .rfl
+      | ctor =>
+        let .lam _ _ _ h := hTerm'
+        cases TShape.ctor_not_le_lam' h
+      | indTy =>
+        let .lam _ _ _ h := hTerm'
+        cases TShape.indTy_not_le_lam' h
+    rintro k a₁ a₂ rfl ⟨⟩
+    have ⟨_, aty, _⟩ := WShape.HasType.forallE_l.1 htyped.isType
+    have hTypA : Γ₀ ⊢ A.subst σ : .sort u :=
+      (HA.subst W.left.toSubstEq).hasType.1
+    have hTypB : A.subst σ :: Γ₀ ⊢ B.subst σ.lift : .sort v :=
+      HB.subst (W.left.toSubstEq.lift HA.defeq.hasType.1)
+    have hA1 := hPi.forallE_inv.1
+    have ⟨_, a', _, le_n, le_a, hA', hSort, hmem'⟩ :=
+      (LE_Interp.sound HA W.left.fits).2 hA1 |>.out
+    have cons := LR.Adequate.cons ihA HA
+    obtain ⟨g, hg, htm⟩ := WShape.HasType.forallE_inv htyped
+    unfold WShape.lam' at hg
+    split at hg <;> [skip; (subst hg; exact (LR _).bot htyped.isType)]
+    rename_i hlam
+    subst hg
+    simp only [LR, LRS, LRS.DefEq.lam_forallE]
+    have aty := WShape.HasTypePi.iff.1 aty
+    refine ⟨A.subst σ, B.subst σ.lift, u, v, .rfl,
+      hTypA, ?_, hTypB, ?_, ?_⟩
+    · exact (LR Γ₀).left_ty <|
+        LR.toValTy le_n le_a aty.1.isType hSort hmem'
+          ((ihA hA' hSort hmem').2 W.left)
+    · simp only [LRS.PiDefEq]
+      have edge : ∀ {{x x' p}}, p.HasType a₁ →
+          Γ₀ ⊢ x ≡ x' : A.subst σ →
+          (LR Γ₀).DefEq x x' (A.subst σ) p a₁ →
+          LRS.PiInstDefEq (LR Γ₀) (B.subst σ.lift)
+            (B.subst σ.lift) x x' (a₂.app p) := by
+        intro x x' p hp ha hv
+        have W' := cons hp hA1 ha hv W.left
+        have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+          (LE_Interp.sound HB W'.fits).2
+            (hPi.forallE_inv'.2 p) |>.out
+        have hsem : (LR Γ₀).TyDefEq
+            ((B.subst σ.lift).inst x) ((B.subst σ.lift).inst x')
+            (a₂.app p) := by
+          simpa [inst_lift_cons] using
+            LR.toValTy le le' (aty.2 _ hp).toType iv hmb
+              ((ihB iB iv hmb).1 W').1
+        have hraw : Γ₀ ⊢
+            (B.subst σ.lift).inst x ≡
+              (B.subst σ.lift).inst x' : .sort v := by
+          simpa only [inst_lift_cons, SExpr.subst] using
+            (HB.substCongr W'.toSubstEq).1
+        exact ⟨hsem, hsem, ⟨v, hraw⟩, ⟨v, hraw⟩⟩
+      exact ⟨edge, fun _ _ hp ha hv => (edge hp ha hv).leftTy⟩
+    have beta {X Y t : SExpr} {σ} :
+        Γ₀ ⊢ .app (.lam (X.subst σ) (Y.subst σ.lift)) t ⤳*
+          Y.subst (σ.cons t) :=
+      inst_lift_cons (x := t) ▸ .tail .rfl .beta
+    refine ⟨fun x x' p hp ha hv => ?_, fun x p hp ha hv => ?_⟩
+    all_goals
+      rw [inst_lift_cons]
+      have hBb_sd := hPi.forallE_inv'.2 p
+      replace IH W := IH W (hTerm'.lam_inv' p) hBb_sd
+        ((WShape.HasTypeLam.iff.1 htm).2.2 p hp)
+    · have W' := cons hp hA1 ha hv W.left
+      constructor
+      · exact ((LR Γ₀).whr beta beta).2 <| ((IH W'.fits).1 W').1
+      · have vtAA' := LR.toValTy le_n le_a aty.1.isType hSort hmem'
+          ((ihA hA' hSort hmem').1 W).1
+        have ha' : Γ₀ ⊢ x ≡ x' : A.subst σ' :=
+          ((HA.substCongr W.toSubstEq).1).defeqDF ha
+        have hv' := (LR Γ₀).conv vtAA' hv
+        have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+          (LE_Interp.sound HB W'.fits).2 hBb_sd |>.out
+        have W2 := cons hp hA1 ha.hasType.1 ((LR Γ₀).left hv) W
+        have vtBB := LR.toValTy le le' (aty.2 _ hp).toType iv hmb
+          ((ihB iB iv hmb).1 W2).1
+        refine ((LR Γ₀).whr beta beta).2 <|
+          (LR Γ₀).conv ((LR Γ₀).symm_ty vtBB) ?_
+        exact ((IH W'.fits).1
+          (cons hp hA1 ha' hv' W.symm.left)).2
+    · have W' := cons hp hA1 ha hv W
+      exact ((LR Γ₀).whr beta beta).2 <|
+        (LR _).trans ((IH W'.fits).2 W'.left) ((IH W'.fits).1 W').2
+  | @forallE Γ A u depth body v hAty hbodyty _ _ =>
+    have hdepth : depth < depth + 1 := Nat.lt_succ_self depth
+    have ihA : ∀ {ρ : Valuation} {n' : Nat} {ma aa : WShape n'},
+        LE_Interp ρ ma.T A → LE_Interp ρ aa.T (.sort u) →
+        ma.HasType aa → LR.Adequate Γ₀ Γ ρ A A (.sort u) ma aa := by
+      intro ρ n' ma aa hA hSort hma
+      exact (restartSelf depth hdepth hA.witness)
+        .rfl hAty hma hSort.witness
+    have ihBody : ∀ {ρ : Valuation} {n' : Nat} {mb ab : WShape n'},
+        LE_Interp ρ mb.T body → LE_Interp ρ ab.T (.sort v) →
+        mb.HasType ab →
+        LR.Adequate Γ₀ (A :: Γ) ρ body body (.sort v) mb ab := by
+      intro ρ n' mb ab hbody hSort hmb
+      exact (restartSelf depth hdepth hbody.witness)
+        .rfl hbodyty hmb hSort.witness
+    exact LR.adequateForallESelf hAty.strong hbodyty.strong
+      hX.toInterp hB.toInterp htyped ihA ihBody
+  | @defeq Γ A B u depth e hEq hAty hBty heTy
+      ihA ihB ihe =>
+    have hdepth : depth < depth + 1 := Nat.lt_succ_self depth
+    have ihA' : ∀ {ρ : Valuation} {n' : Nat} {ma sa : WShape n'},
+        LE_Interp ρ ma.T A → LE_Interp ρ sa.T (.sort u) →
+        ma.HasType sa → LR.Adequate Γ₀ Γ ρ A A (.sort u) ma sa := by
+      intro ρ n' ma sa hA hSort hma
+      exact (restartSelf depth hdepth hA.witness)
+        .rfl hAty hma hSort.witness
+    have ihB' : ∀ {ρ : Valuation} {n' : Nat} {mb sb : WShape n'},
+        LE_Interp ρ mb.T B → LE_Interp ρ sb.T (.sort u) →
+        mb.HasType sb → LR.Adequate Γ₀ Γ ρ B B (.sort u) mb sb := by
+      intro ρ n' mb sb hB hSort hmb
+      exact (restartSelf depth hdepth hB.witness)
+        .rfl hBty hmb hSort.witness
+    have ihe' : ∀ {ρ : Valuation} {n' : Nat} {me ae : WShape n'},
+        LE_Interp ρ me.T e → LE_Interp ρ ae.T A →
+        me.HasType ae → LR.Adequate Γ₀ Γ ρ e e A me ae := by
+      intro ρ n' me ae he hA hme
+      exact (restartSelf depth hdepth he.witness)
+        .rfl heTy hme hA.witness
+    exact defeqStep hdepth hAty hEq hX.toInterp hB.toInterp htyped
+      ihA' ihB' ihe'
+
+/-- The exact-root syntax-directed worker is stable under lowering because
+`Witness.mono` and `RDeepChildren.mono` retain the selected evaluator tree. -/
+theorem LR.selfAdequateAtStep
+    (depth : Nat)
+    (defeqStep : LR.SelfAdequateDefeqStepAt Γ₀ depth)
+    (hΓ₀ : Ctx.WF Γ₀)
+    (constStep : LR.SelfAdequateConstStep Γ₀)
+    {ρ root X} (hX : LE_Interp.Witness ρ root X)
+    (children : hX.RDeepChildren (LR.CoherentSeedAt Γ₀ depth))
+    (lower : ∀ (d' : Nat), d' < depth → ∀ {ρ root X}
+      (hX' : LE_Interp.Witness ρ root X),
+      hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+      LR.CoherentRetainedAt Γ₀ hX' d') :
+    LR.SelfAdequateAt Γ₀ hX depth := by
+  intro n mx bx Δ core B hroot hTyping htyped hB
+  exact LR.selfAdequateExactAtStep depth defeqStep hΓ₀ constStep
+    (hX.mono hroot) (children.mono hroot) lower
+    rfl hTyping htyped hB
+
+/-- Reuse the syntax-directed self-adequacy algebra without forgetting the
+provenance-sensitive edge classification.
+
+Both the constant producer and every strictly-smaller restart receive the
+exact `CoherentSeedAt` tree.  In particular, this adapter does not map a
+local seed to the old proof-independent retained package. -/
+theorem LR.coherentSelfStep_of_steps
+    (defeqStep : ∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth)
+    (hΓ₀ : Ctx.WF Γ₀)
+    (constStep : LR.SelfAdequateConstStep Γ₀) :
+    LR.CoherentSelfStep Γ₀ := by
+  intro depth ρ root X hX children lower
+  intro n mx bx Δ core B hroot hTyping htyped hB
+  exact LR.selfAdequateAtStep (hX := hX)
+    depth (defeqStep depth) hΓ₀ constStep
+    children lower
+    hroot hTyping htyped hB
+
+/-- Compatibility construction of the coherent self algebra from completed
+stratified inversion.  The recursion plumbing itself is independent of this
+choice; a depth-bounded caller may supply a different `defeqStep`. -/
+theorem LR.CoherentSelfStep.of_stratifiedInversion
+    (inv : JointStratifiedInversion) (hΓ₀ : Ctx.WF Γ₀)
+    (constStep : LR.SelfAdequateConstStep Γ₀) :
+    LR.CoherentSelfStep Γ₀ :=
+  LR.coherentSelfStep_of_steps
+    (fun depth =>
+      LR.SelfAdequateDefeqStepAt.of_stratifiedInversion inv hΓ₀ depth)
+    hΓ₀ constStep
+
+/-- A zero-arity semantic definition rule is also a concrete one-step head
+reduction.  Keeping this consequence next to adequacy makes the recursive
+constant case consume the local, proof-carrying contraction rather than
+reconstructing a registered equation from global membership. -/
+theorem Params.Semantic.defn_whRed
+    {c : Name} {r : (Pattern.const c).RHS × (Pattern.const c).Check}
+    (hpat : Params.Pat (.const c) r)
+    {ci : VConstant} {ls : List SLevel} {Γ : List SExpr}
+    (hci : Params.env.constants c = some ci) (hlen : ls.length = ci.uvars) :
+    ∃ (value : VExpr) (closed : value.Closed),
+      r = (.fixed value closed, .true) ∧
+      IsDefEqStrong Γ (.const c ls) (SExpr.mkInst ls value)
+        (SExpr.mkInst ls ci.type) ∧
+      WHRed Γ (.const c ls) (SExpr.mkInst ls value) := by
+  obtain ⟨value, closed, hr, hdef⟩ := Params.Semantic.defn hpat
+  subst r
+  have hstrong : IsDefEqStrong Γ (.const c ls) (SExpr.mkInst ls value)
+      (SExpr.mkInst ls ci.type) := hdef (Γ := Γ) hci hlen
+  obtain ⟨m2, hmatch⟩ : ∃ m2,
+      (Pattern.const c).MatchesS (.const c ls) ls m2 :=
+    ⟨_, .const (c := c) (ls := ls)⟩
+  let action : Pattern.Action Γ (.fixed value closed, .true)
+      (.const c ls) ls m2 (SExpr.mkInst ls ci.type) := {
+    pat := hpat
+    matched := hmatch
+    dfs := []
+    defeqs := rfl
+    checked := by simp
+    sound := hstrong.defeq }
+  exact ⟨value, closed, rfl, hstrong, .extra action⟩
+
+/-- The recursive iota-leaf obligation of the constant self-adequacy
+producer, stated against the constant witness's own retained evaluator
+data.
+
+Everything the eventual discharge may consume is received explicitly: the
+per-`R`-edge inspectable seeds and exact child trees of the constant
+witness (never a reselected interpretation), the caller's substitution
+certificate pinning the ambient valuation, and the strictly smaller
+coherent restart family.  The seeds are deliberately NOT restated at
+`Valuation.nil`: a per-edge retained result quantifies over `SubstWF` at
+the seed's own valuation and is not transportable across `closedAt`,
+while the prepared consumer `iotaDefEq_of_ctorExactAt_coherent` threads
+exactly this ambient-`W` interface through `CoherentRhsSeedAt.mono` with
+no valuation change (see the premortem's 2026-08-15 interface-decision
+section).  The global `iotaWitnessStep` obligation never appears.
+
+Status (2026-08-15 rung audit, revised by the same day's structural
+repair): the major-side decomposition is still open, but its residual has
+been narrowed.  Splitting the joint match and normalizing the major
+through `LRS.CtorDefEq.toChain` is available, and every per-link consumer
+is inversion-free.  Folding the normalized chain no longer needs
+`LR.MajorChainFoldStep`: `LRS.CtorDefEq.foldRaw_of_majorChainAnchorStep`
+reaches the same conclusion from `LR.MajorChainAnchorStep`, whose interior
+half is a per-leaf retyping carried by the native `LRS.CtorExact`
+certificate rather than raw type uniqueness at arbitrary terms, and whose
+remaining raw input is subject reduction at the two root views only.  A
+second, mechanical layer also remains: the framed leaf is native at its
+own level, so the rectangle must be run there and transported back through
+`LogRel.LiftEquiv.rect`.  See the premortem's 2026-08-15 chain-wall
+entries. -/
+def LR.CoherentIotaLeafStep (Γ₀ : List SExpr) : Prop :=
+  ∀ (depth : Nat) {Δ : List SExpr} {σ σ' : Subst}
+      {ρ : Valuation} {c : Name} {ls : List SLevel}
+      {R : TShape → SExpr → Prop}
+      (hR : ∀ m M, R m M → LE_Interp.Witness ρ m M),
+    Ctx.WF Γ₀ →
+    LR.SubstWF Γ₀ σ σ' Δ ρ →
+    (∀ m M (hr : R m M), LR.CoherentSeedAt Γ₀ depth (hR m M hr)) →
+    (∀ m M (hr : R m M),
+      (hR m M hr).RDeepChildren (LR.CoherentSeedAt Γ₀ depth)) →
+    (∀ (d' : Nat), d' < depth →
+      ∀ {ρ' : Valuation} {root : TShape} {X : SExpr}
+        (hX' : LE_Interp.Witness ρ' root X),
+        hX'.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+        LR.CoherentRetainedAt Γ₀ hX' d') →
+    ∀ (level : Nat),
+      LR.IotaLeafDefEqAt Γ₀ level c ls (LE_Interp.Lower R)
+
+/-- The definitional-unfold obligation of the constant producer at a local
+(guarded-restart) evaluator seed.
+
+The stratified `const` rule certifies only the constant's type, so the
+registered value's certificate depth is unrelated to a local seed's
+budget: a genuine semantic child covers every depth through its all-depth
+result, but a rebuilt child is pinned to one index.  This hypothesis
+names that residual budget question — a local coherent result on a
+registered definitional value extends to the value's own certificate
+depths — instead of widening `CoherentSeedAt` mid-construction. -/
+def LR.ConstDefnLocalStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed},
+    Params.Pat (.const c) (.fixed value closed, .true) →
+    Params.env.constants c = some ci →
+    ∀ {ls : List SLevel}, ls.length = ci.uvars →
+    ∀ (depth : Nat) {ρ : Valuation} {root : TShape}
+      (hV : LE_Interp.Witness ρ root (SExpr.mkInst ls value)),
+      LR.CoherentRetainedAt Γ₀ hV depth →
+      hV.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+      ∀ (depth' : Nat), LR.SelfAdequateAt Γ₀ hV depth'
+
+/-- The strictly deeper half of `ConstDefnLocalStep`, which is all of its
+residual content.
+
+`LR.SelfAdequateAt` mentions its depth index only in the stratified
+certificate it consumes, and `HasTypeStratifiedS.mono` raises a certificate
+to any larger index.  So a local seed at index `depth` already discharges
+every `depth' ≤ depth` without any further hypothesis
+(`ConstDefnLocalStep.of_deepStep` below), and the whole question is the
+strictly deeper case.
+
+That is exactly where the definitional-unfold budget lives.  The stratified
+`const` rule certifies only `SExpr.mkInst ls ci.type` (SExpr:2383-2387), so
+nothing in a constant's own derivation bounds the stratified depth of its
+registered value — a definitional value is routinely deeper than its
+declared type.  Closedness of the value does not help: it constrains
+substitution, not stratification depth.  A discharge must therefore couple
+the budget to the seed at its creation point, in the manner
+`CoherentRhsSeedAt` already models one level up. -/
+def LR.ConstDefnDeepStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed},
+    Params.Pat (.const c) (.fixed value closed, .true) →
+    Params.env.constants c = some ci →
+    ∀ {ls : List SLevel}, ls.length = ci.uvars →
+    ∀ (depth : Nat) {ρ : Valuation} {root : TShape}
+      (hV : LE_Interp.Witness ρ root (SExpr.mkInst ls value)),
+      LR.CoherentRetainedAt Γ₀ hV depth →
+      hV.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+      ∀ (depth' : Nat), depth < depth' → LR.SelfAdequateAt Γ₀ hV depth'
+
+/-- Only strictly deeper certificates are residual.  A certificate at or
+below the local seed's own index is raised to that index by
+`HasTypeStratifiedS.mono` and consumed by the local result directly, so this
+reduction spends no adequacy content whatsoever — it is pure depth
+arithmetic. -/
+theorem LR.ConstDefnLocalStep.of_deepStep
+    (deep : LR.ConstDefnDeepStep Γ₀) : LR.ConstDefnLocalStep Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth ρ root hV hlocal children
+    depth'
+  rcases Nat.lt_or_ge depth depth' with hlt | hle
+  · exact deep hpat hreg hlen depth hV hlocal children depth' hlt
+  · intro n mx bx Δ core B hroot hstrat hmem hB
+    exact hlocal.1 hroot (hstrat.mono hle) hmem hB
+
+/-! ### Retention and demand narrowing for the definitional-unfold budget
+
+The two Props above commit two erasures at their single call site
+(`LR.SelfAdequateConstStep.of_steps`).  In the *supply* direction they drop
+the strictly smaller coherent restart family `lower` and `Ctx.WF Γ₀`, both
+of which are in scope where they are consumed: the producer knew more than
+it handed over.  In the *demand* direction their conclusion quantifies over
+every `Δ`, `B` and `core` of `LR.SelfAdequateAt`, while the call site
+consumes exactly one instance, pinned to `B := SExpr.mkInst ls ci.type` and
+`core := true` by the registered definitional equation
+`Params.Semantic.defn_whRed`.
+
+Unlike the depth index, the *type* index is fixed by the declaration rather
+than chosen downstream, so it can be narrowed leaf-locally — the same move
+the chain-wall repair made (narrow the subject, keep the position).  The
+declarations below carry out both narrowings; the originals are kept
+unchanged as reference statements, and the faithfulness lemmas record that
+the new forms are weakenings, so whatever discharges the old obligations
+discharges these.
+
+This does NOT discharge the residual: it narrows it.  What remains still
+needs the δ-rank well-founded component (separate design pass). -/
+
+/-- Retentive form of `LR.ConstDefnLocalStep`: the restart family `lower`
+and `Ctx.WF Γ₀` are retained instead of erased. -/
+def LR.ConstDefnLocalStepR (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed},
+    Params.Pat (.const c) (.fixed value closed, .true) →
+    Params.env.constants c = some ci →
+    ∀ {ls : List SLevel}, ls.length = ci.uvars →
+    ∀ (depth : Nat) {ρ : Valuation} {root : TShape}
+      (hV : LE_Interp.Witness ρ root (SExpr.mkInst ls value)),
+      LR.CoherentRetainedAt Γ₀ hV depth →
+      hV.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+      (∀ (d' : Nat), d' < depth →
+        ∀ {ρ' : Valuation} {root' : TShape} {X : SExpr}
+          (hX : LE_Interp.Witness ρ' root' X),
+          hX.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+          LR.CoherentRetainedAt Γ₀ hX d') →
+      Ctx.WF Γ₀ →
+      ∀ (depth' : Nat), LR.SelfAdequateAt Γ₀ hV depth'
+
+/-- Retentive form of `LR.ConstDefnDeepStep`. -/
+def LR.ConstDefnDeepStepR (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed},
+    Params.Pat (.const c) (.fixed value closed, .true) →
+    Params.env.constants c = some ci →
+    ∀ {ls : List SLevel}, ls.length = ci.uvars →
+    ∀ (depth : Nat) {ρ : Valuation} {root : TShape}
+      (hV : LE_Interp.Witness ρ root (SExpr.mkInst ls value)),
+      LR.CoherentRetainedAt Γ₀ hV depth →
+      hV.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+      (∀ (d' : Nat), d' < depth →
+        ∀ {ρ' : Valuation} {root' : TShape} {X : SExpr}
+          (hX : LE_Interp.Witness ρ' root' X),
+          hX.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+          LR.CoherentRetainedAt Γ₀ hX d') →
+      Ctx.WF Γ₀ →
+      ∀ (depth' : Nat), depth < depth' → LR.SelfAdequateAt Γ₀ hV depth'
+
+/-- Only strictly deeper certificates are residual — the
+`LR.ConstDefnLocalStep.of_deepStep` argument, threaded through the retained
+restart family unchanged. -/
+theorem LR.ConstDefnDeepStepR.toLocal {Γ₀ : List SExpr}
+    (deep : LR.ConstDefnDeepStepR Γ₀) : LR.ConstDefnLocalStepR Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth ρ root hV hlocal children
+    lower hΓ₀ depth'
+  rcases Nat.lt_or_ge depth depth' with hlt | hle
+  · exact deep hpat hreg hlen depth hV hlocal children lower hΓ₀ depth' hlt
+  · intro n mx bx Δ core B hroot hstrat hmem hB
+    exact hlocal.1 hroot (hstrat.mono hle) hmem hB
+
+/-- Faithfulness: the retentive Props are *weakenings*, not restatements. -/
+theorem LR.ConstDefnDeepStepR.of_constDefnDeepStep {Γ₀ : List SExpr}
+    (H : LR.ConstDefnDeepStep Γ₀) : LR.ConstDefnDeepStepR Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth ρ root hV hlocal children
+    _lower _hΓ₀ depth' hlt
+  exact H hpat hreg hlen depth hV hlocal children depth' hlt
+
+/-- Faithfulness for the local form. -/
+theorem LR.ConstDefnLocalStepR.of_constDefnLocalStep {Γ₀ : List SExpr}
+    (H : LR.ConstDefnLocalStep Γ₀) : LR.ConstDefnLocalStepR Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth ρ root hV hlocal children
+    _lower _hΓ₀ depth'
+  exact H hpat hreg hlen depth hV hlocal children depth'
+
+/-- The δ-unfold obligation as the single instance the call site consumes.
+
+Strictly weaker than `LR.ConstDefnDeepStepR`: the certificate depth `nV` is
+now bound where the certificate is supplied rather than universally ahead of
+it, and the observed type is pinned to the registered `SExpr.mkInst ls
+ci.type` at `core := true`. -/
+def LR.ConstDefnDeepInstStep (Γ₀ : List SExpr) : Prop :=
+  ∀ {c : Name} {ci : VConstant} {value : VExpr} {closed : value.Closed},
+    Params.Pat (.const c) (.fixed value closed, .true) →
+    Params.env.constants c = some ci →
+    ∀ {ls : List SLevel}, ls.length = ci.uvars →
+    ∀ (depth : Nat) {ρ : Valuation} {root : TShape}
+      (hV : LE_Interp.Witness ρ root (SExpr.mkInst ls value)),
+      LR.CoherentRetainedAt Γ₀ hV depth →
+      hV.RDeepChildren (LR.CoherentSeedAt Γ₀ depth) →
+      (∀ (d' : Nat), d' < depth →
+        ∀ {ρ' : Valuation} {root' : TShape} {X : SExpr}
+          (hX : LE_Interp.Witness ρ' root' X),
+          hX.RDeepChildren (LR.CoherentSeedAt Γ₀ d') →
+          LR.CoherentRetainedAt Γ₀ hX d') →
+      Ctx.WF Γ₀ →
+      ∀ {Γ : List SExpr} {n : Nat} {mx bx : WShape n} {nV : Nat},
+        mx.T ≤ root →
+        HasTypeStratifiedS Γ (SExpr.mkInst ls value)
+          (SExpr.mkInst ls ci.type) true nV →
+        mx.HasType bx →
+        LE_Interp.Witness ρ bx.T (SExpr.mkInst ls ci.type) →
+        LR.Adequate Γ₀ Γ ρ (SExpr.mkInst ls value) (SExpr.mkInst ls value)
+          (SExpr.mkInst ls ci.type) mx bx
+
+/-! #### The δ-rank producer
+
+The environment supplies only the ranked certificate for a registered
+definition.  Recursion remains an explicit premise: it is outermost in the
+δ-rank and independent of the existing depth/witness recursion.  This
+separation prevents a cyclic `VEnv.WF` block from silently becoming a
+termination proof.
+-/
+
+/-- `SelfAdequateAt` restricted to typing derivations below one δ-rank. -/
+def LR.SelfAdequateAtR [Params.DeltaRank] (Γ₀ : List SExpr)
+    {rho : Valuation} {root : TShape} {X : SExpr}
+    (_hX : LE_Interp.Witness rho root X) (depth rankBound : Nat) : Prop :=
+  ∀ {n : Nat} {mx bx : WShape n} {Delta : List SExpr}
+      {core : Bool} {B : SExpr},
+    mx.T ≤ root →
+    HasTypeStratifiedR Params.DeltaRank.rank Delta X B core depth rankBound →
+    mx.HasType bx →
+    LE_Interp.Witness rho bx.T B →
+    LR.Adequate Γ₀ Delta rho X X B mx bx
+
+/-- Adequacy at every rank recovers the unranked statement. -/
+theorem LR.selfAdequateAt_of_allRanks [Params.DeltaRank]
+    {hX : LE_Interp.Witness rho root X} {depth : Nat}
+    (H : ∀ rankBound, LR.SelfAdequateAtR Γ₀ hX depth rankBound) :
+    LR.SelfAdequateAt Γ₀ hX depth := by
+  intro n mx bx Delta core B hroot hstrat hmem hB
+  obtain ⟨rankBound, hranked⟩ :=
+    HasTypeStratifiedR.exists_rank Params.DeltaRank.rank hstrat
+  exact H rankBound hroot hranked hmem hB
+
+/-- Unranked self-adequacy can always serve a fixed rank. -/
+theorem LR.SelfAdequateAt.toRank [Params.DeltaRank]
+    {hX : LE_Interp.Witness rho root X} {depth rankBound : Nat}
+    (H : LR.SelfAdequateAt Γ₀ hX depth) :
+    LR.SelfAdequateAtR Γ₀ hX depth rankBound :=
+  fun hroot hstrat hmem hB => H hroot hstrat.toS hmem hB
+
+/-- The induction hypotheses supplied by an outer strong recursion on the
+δ-rank. -/
+def LR.DeltaRankRestart [Params.DeltaRank] (Γ₀ : List SExpr)
+    (rankBound : Nat) : Prop :=
+  ∀ rank' : Nat, rank' < rankBound →
+    ∀ {rho : Valuation} {root : TShape} {X : SExpr}
+      (hX : LE_Interp.Witness rho root X) (depth : Nat),
+      LR.SelfAdequateAtR Γ₀ hX depth rank'
+
+theorem LR.DeltaRankRestart.of_le [Params.DeltaRank]
+    {rankBound rankBound' : Nat} (hle : rankBound' ≤ rankBound)
+    (H : LR.DeltaRankRestart Γ₀ rankBound) :
+    LR.DeltaRankRestart Γ₀ rankBound' :=
+  fun rank' hlt => H rank' (Nat.lt_of_lt_of_le hlt hle)
+
+/-- The sole staged δ obligation: every rank receives its strict
+predecessors. -/
+def LR.DeltaRankStage [Params.DeltaRank] (Γ₀ : List SExpr) : Prop :=
+  ∀ rankBound, LR.DeltaRankRestart Γ₀ rankBound
+
+/-- The narrowed definitional-unfold obligation follows directly from the
+environment certificate and the restart at the unfolded constant's rank. -/
+theorem LR.ConstDefnDeepInstStep.of_deltaRank [Params.DeltaRank]
+    (restart : ∀ c : Name,
+      LR.DeltaRankRestart Γ₀ (Params.DeltaRank.rank c)) :
+    LR.ConstDefnDeepInstStep Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth rho root hV hlocal children
+    lower hGamma Gamma n mx bx nV hroot hstrat htyped hB
+  obtain ⟨nV', rankV, hlt, hcert⟩ :=
+    Params.DeltaRank.defnCert (Γ := Gamma) hpat hreg hlen
+  exact restart c rankV hlt hV nV' hroot hcert htyped hB
+
+/-- The stronger retentive interface is exactly what a complete outer rank
+stage supplies; it adds no further semantic premise. -/
+theorem LR.ConstDefnDeepStepR.of_deltaRankStage [Params.DeltaRank]
+    (stage : LR.DeltaRankStage Γ₀) : LR.ConstDefnDeepStepR Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth rho root hV hlocal children
+    lower hGamma depth' hlt
+  refine LR.selfAdequateAt_of_allRanks (hX := hV) fun rankBound => ?_
+  exact stage (rankBound + 1) rankBound (Nat.lt_succ_self rankBound) hV depth'
+
+/-- info: 'Lean4Lean.SExpr.LR.ConstDefnDeepInstStep.of_deltaRank' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms LR.ConstDefnDeepInstStep.of_deltaRank
+
+/-- info: 'Lean4Lean.SExpr.LR.ConstDefnDeepStepR.of_deltaRankStage' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms LR.ConstDefnDeepStepR.of_deltaRankStage
+
+/-- Faithfulness: the narrowed form is implied by the retentive form, hence
+(through `LR.ConstDefnDeepStepR.of_constDefnDeepStep`) by the current
+`LR.ConstDefnDeepStep`. -/
+theorem LR.ConstDefnDeepInstStep.of_deepStepR {Γ₀ : List SExpr}
+    (H : LR.ConstDefnDeepStepR Γ₀) : LR.ConstDefnDeepInstStep Γ₀ := by
+  intro c ci value closed hpat hreg ls hlen depth ρ root hV hlocal children
+    lower hΓ₀ Γ n mx bx nV hroot hstrat htyped hB
+  rcases Nat.lt_or_ge depth nV with hlt | hle
+  · exact H hpat hreg hlen depth hV hlocal children lower hΓ₀ nV hlt
+      hroot hstrat htyped hB
+  · exact hlocal.1 hroot (hstrat.mono hle) htyped hB
+
+/-- Produce the constant case of retained self-adequacy from the witness's
+own `children`/`lower` data.
+
+This is the derivation-induction-free remake of the constant case: the
+constant's type restarts through `lower` at the strictly smaller
+certificate depth carried by the stratified `const` rule; the constructor
+and inductive-type heads are discharged from that same restart; the
+definitional unfold consumes the seed retained on the witness's own `R`
+edge (`ConstDefnLocalStep` covers only the local-seed branch); and every
+reached iota leaf consumes `CoherentIotaLeafStep` at the witness's own
+seeds under the ambient substitution certificate.  Neither the global
+`iotaWitnessStep` obligation nor any same-depth adequacy is consumed. -/
+theorem LR.SelfAdequateConstStep.of_steps
+    (hΓ₀ : Ctx.WF Γ₀)
+    (leafStep : LR.CoherentIotaLeafStep Γ₀)
+    (defnStep : LR.ConstDefnDeepInstStep Γ₀) :
+    LR.SelfAdequateConstStep Γ₀ := by
+  intro c ci Γ ls u depth ρ n mx bx hreg hlen hTy lower htyped hB hX children
+  cases children with
+  | bot => exact LR.Adequate.bot htyped.isType
+  | const cA pR cR =>
+    rename_i a₀ ci' R m' hm'ty n₀ hR hle hreg' hlen' hA'w hC
+    cases hreg.symm.trans hreg'
+    have restartSelf : ∀ {ρ' : Valuation} {root : TShape} {X : SExpr}
+        (hX' : LE_Interp.Witness ρ' root X),
+        LR.SelfAdequateAt Γ₀ hX' depth := fun hX' =>
+      (LR.CoherentRetainedAt.restart (lower := lower)
+        (Nat.lt_succ_self depth) (hX := hX')).1
+    suffices h : ∀ {σ σ'}, LR.SubstWF Γ₀ σ σ' Γ ρ →
+        (LR Γ₀).DefEq (.const c ls) (.const c ls)
+          ((SExpr.mkInst ls ci.type).subst σ) mx bx from
+      ⟨fun _ _ W => ⟨h W, h W⟩, fun _ W => h W⟩
+    intro σ σ' W
+    rw [(Params.henv.closedC hreg).mkInstS.subst_eq .zero]
+    have hC' : LE_Interp.Const c ls (LE_Interp.Lower R) [] mx.T :=
+      hC.mono hle fun le hr => ⟨_, le, hr⟩
+    cases hC' with
+    | bot => exact (LR Γ₀).bot htyped.isType
+    | lam hrec hlam =>
+      rename_i fsem
+      cases htyped.unfold with
+      | bot hm => exact (LR Γ₀).bot hm
+      | sort => exact (TShape.sort_not_le_lam' hlam).elim
+      | forallE => exact (TShape.forallE_not_le_lam' hlam).elim
+      | @lam k f a₁ a₂ htm =>
+        obtain ⟨n', mTy, sTy, le_n, le_a, hTy', hSort, hmTy⟩ :=
+          (LE_Interp.sound hTy.strong W.left.fits).2 hB.toInterp |>.out
+        have hty' := (restartSelf hTy'.witness .rfl hTy hmTy
+          hSort.witness).2 W.left
+        rw [(Params.henv.closedC hreg).mkInstS.subst_eq .zero] at hty'
+        have hty : (LR Γ₀).TyDefEq (mkInst ls ci.type) (mkInst ls ci.type)
+            (.forallE a₁ a₂) :=
+          toValTy le_n le_a htyped.isType hSort hmTy hty'
+        rw [LR_succ] at hty ⊢
+        unfold WShape.lam'
+        split <;> rename_i hf
+        · obtain ⟨A₁, A₂, _, _, u₁, u₂, hred, _, hA₁, hA₂, hvalA₁, hpi⟩ := hty
+          refine (LRS.DefEq.lam_forallE (M := .const c ls) (N := .const c ls)
+            (A := mkInst ls ci.type) (f := f) (hf := hf) (a₁ := a₁) (a₂ := a₂)
+            (LR Γ₀)).2
+            ⟨A₁, A₂, u₁, u₂, hred, hA₁.leftType,
+              (LR Γ₀).left_ty hvalA₁, hA₂.leftType, LRS.PiDefEq.left hpi, ?_⟩
+          have eval : ∀ {K : Nat}, K = k → ∀
+              {x y : SExpr} {p : WShape K} {x₀ y₀ : WShape n₀},
+              p.HasType (a₁.lift K) →
+              Γ₀ ⊢ x ≡ y : A₁ →
+              (LR Γ₀).DefEq x y A₁ p (a₁.lift K) →
+              (x₀, y₀) ∈ fsem → x₀.T ≤ p.T →
+              ((f.lift K).app p).T ≤ y₀.T →
+              (LR Γ₀).DefEq ((const c ls).app x) ((const c ls).app y)
+                (A₂.inst x) ((f.lift K).app p) ((a₂.lift K).app p) := by
+            intro K hK
+            subst K
+            intro x y p x₀ y₀ hp hxy hv hmem₀ hx₀ hy₀
+            have hn : k ≤ k := Nat.le_refl k
+            have hPiK : LRS.PiDefEq (LR Γ₀) A₁ A₂ A₂
+                (a₁.lift k) (a₂.lift k) :=
+              (LRS.PiDefEq.lift hn htm.1).2 (LRS.PiDefEq.left hpi)
+            have hAK : (LR Γ₀).TyDefEq (A₂.inst x) (A₂.inst x)
+                ((a₂.lift k).app p) :=
+              hPiK.2 hp hxy.hasType.1 ((LR Γ₀).left hv)
+            have hout : ((f.lift k).app p).HasType ((a₂.lift k).app p) :=
+              (WShape.HasTypeLam.iff.1 ((WShape.HasTypeLam.lift hn).2 htm)).2.2 p hp
+            have hType₀ : Γ₀ ⊢ mkInst ls ci.type : .sort u := by
+              simpa only [(Params.henv.closedC hreg).mkInstS.subst_eq .zero,
+                SExpr.subst] using
+                (hTy.strong.subst W.left.toSubstEq).hasType.1
+            have hTypePi : Γ₀ ⊢
+                mkInst ls ci.type ≡ .forallE A₁ A₂ : .sort u :=
+              hred.defeq hType₀
+            have hConstPi : Γ₀ ⊢ .const c ls : .forallE A₁ A₂ :=
+              hTypePi.defeqDF (.const hreg hlen)
+            have hAppTerm : Γ₀ ⊢
+                SExpr.app (SExpr.const c ls) x ≡
+                  SExpr.app (SExpr.const c ls) y : A₂.inst x :=
+              .appDF hConstPi hxy
+            have hAppType : Γ₀ ⊢ A₂.inst x : .sort u₂ :=
+              (IsDefEq.beta hA₂.leftType hxy.hasType.1).hasType.2
+            have hAppSpineX : SExpr.SpineWF Γ₀ (mkInst ls ci.type)
+                [x] (A₂.inst x) := by
+              simpa only [List.nil_append] using
+                (SExpr.SpineWF.nil (Γ := Γ₀) (A := mkInst ls ci.type)).snoc
+                  hTypePi hxy.hasType.1
+            obtain ⟨_, hAppCodomain⟩ := (hPiK.1 hp hxy hv).leftDefEq
+            have hAppSpineY : SExpr.SpineWF Γ₀ (mkInst ls ci.type)
+                [y] (A₂.inst x) := by
+              have hspine :=
+                (SExpr.SpineWF.nil (Γ := Γ₀) (A := mkInst ls ci.type)).snoc
+                  hTypePi hxy.hasType.2
+              exact SExpr.SpineWF.ret hspine hAppCodomain.symm
+            have hA₁K : (LR Γ₀).TyDefEq A₁ A₁ (a₁.lift k) :=
+              (LR.TyDefEq.lift hn
+                (WShape.HasTypePi.iff.1 htm.1).1.isType).2
+                ((LR Γ₀).left_ty hvalA₁)
+            let hAppPair : SExpr.SpineWF.LastPair Γ₀
+                (mkInst ls ci.type) [] [] x y (A₂.inst x) := {
+                prefixType := mkInst ls ci.type
+                domain := A₁
+                codomain := A₂
+                piSort := u
+                resultSortX := u₂
+                resultSortY := _
+                prefixX := .nil
+                prefixY := .nil
+                pi := hTypePi
+                major := hxy
+                resultX := hAppType
+                resultY := hAppCodomain.symm }
+            have hAppAligned : LRS.CtorSpineDefEq (LR Γ₀)
+                (mkInst ls ci.type) [x] [y] [p] (A₂.inst x) :=
+              .cons .nil hTypePi hp hA₁K hxy hv hAppCodomain.symm
+            have hAppLeaf : LR.PatternLeafSpine Γ₀ (LR Γ₀)
+                (mkInst ls ci.type) [x] [y] [p] (A₂.inst x)
+                ((f.lift k).app p) ((a₂.lift k).app p) := {
+              majorX := x
+              recXs := []
+              majorY := y
+              recYs := []
+              majorShape := p
+              recShapes := []
+              majorTypeShape := a₁.lift k
+              resultShape := f.lift k
+              resultTypeShape := a₂.lift k
+              args_eq := rfl
+              args'_eq := rfl
+              rargs_eq := rfl
+              out_eq := rfl
+              outTy_eq := rfl
+              pair := hAppPair
+              majorHasType := hp
+              resultType := (WShape.HasTypePi.lift hn).2 htm.1
+              majorType := hA₁K
+              majorRel := hv
+              aligned := hAppAligned
+              pi := hPiK }
+            have evalPat : LR.PatternLeafDefEqAt Γ₀ k c ls
+                (LE_Interp.Lower R) :=
+              LR.PatternLeafDefEqAt.of_iota
+                (leafStep (depth + 1) hR hΓ₀ W pR cR lower k)
+            simpa only [List.foldr_cons, List.foldr_nil] using
+              LR.constDefEq (fun le hr => hr.mono le)
+                (hrec x₀ y₀ hmem₀) evalPat
+                (.cons hx₀ .nil) hAppLeaf
+                hAppTerm ⟨u₂, hAppType⟩ (.const hreg hlen) hAppSpineX hAppSpineY
+                hout hAK hy₀
+          exact LR.constLamDefEq (hf := hf) (nArgs := 0) htm hlam
+            (fun {_ _ _ _ _} hp hxy hv hmem₀ hx₀ hy₀ =>
+              LogRel.DefEqRect.diagonal
+                (eval (Nat.max_eq_left (Nat.zero_le k))
+                  hp hxy hv hmem₀ hx₀ hy₀))
+        · exact (LR Γ₀).bot htyped.isType
+      | ctor => exact (TShape.ctor_not_le_lam' hlam).elim
+      | indTy => exact (TShape.indTy_not_le_lam' hlam).elim
+    | ctor hcl hctor =>
+      cases htyped.unfold with
+      | bot hm => exact (LR Γ₀).bot hm
+      | sort => exact (TShape.sort_not_le_ctor' hctor).elim
+      | forallE => exact (TShape.forallE_not_le_ctor' hctor).elim
+      | lam htm =>
+        unfold WShape.lam' at hctor ⊢
+        split at hctor <;> rename_i hnz
+        · exact (TShape.lam_not_le_ctor' hctor).elim
+        · simpa [hnz] using (LR Γ₀).bot htyped.isType
+      | @ctor k c' l' h' =>
+        obtain ⟨hc, hl⟩ := TShape.ctor_le_ctor'_nil (by simpa using hcl) hctor
+        subst c'
+        subst l'
+        obtain ⟨n', mTy, sTy, le_n, le_a, hTy', hSort, hmTy⟩ :=
+          (LE_Interp.sound hTy.strong W.left.fits).2 hB.toInterp |>.out
+        have hty' := (restartSelf hTy'.witness .rfl hTy hmTy
+          hSort.witness).2 W.left
+        rw [(Params.henv.closedC hreg).mkInstS.subst_eq .zero] at hty'
+        have htyB : (LR Γ₀).TyDefEq (mkInst ls ci.type) (mkInst ls ci.type)
+            .indTy :=
+          toValTy le_n le_a htyped.isType hSort hmTy hty'
+        have hhead : LRS.IndTyHead Γ₀ (mkInst ls ci.type) := by
+          rw [LR_succ] at htyB
+          have h : LRS.IndTyHead Γ₀ (mkInst ls ci.type) ∧
+              LRS.IndTyHead Γ₀ (mkInst ls ci.type) := htyB
+          exact h.1
+        rw [LR_succ]
+        change LRS.IndDefEq Γ₀ (LR Γ₀) (const c ls) (const c ls) (mkInst ls ci.type)
+          (WShape.ctor c [] h')
+        exact ⟨hhead, LRS.CtorDefEq.exact
+          (IH := LR Γ₀) (c := c) (rargs := [])
+          (M := const c ls) (N := const c ls)
+          (ls := ls) (ls' := ls) (args := []) (args' := [])
+          (by simpa using hcl) rfl rfl rfl .rfl .rfl
+          (.const hreg hlen) (.const hreg hlen)
+          (.nil (Γ := Γ₀) (A := mkInst ls ci.type))
+          (.nil (Γ := Γ₀) (A := mkInst ls ci.type)) .nil
+          (LRS.CtorSpineDefEq.nil
+            (IH := LR Γ₀) (Head := mkInst ls ci.type))
+          (LRS.CtorSpineDefEq.nil
+            (IH := LR Γ₀) (Head := mkInst ls ci.type))⟩
+      | indTy => exact (TShape.indTy_not_le_ctor' hctor).elim
+    | indTy hcl hind =>
+      cases htyped.unfold with
+      | bot hm => exact (LR Γ₀).bot hm
+      | sort => exact (TShape.sort_not_le_indTy hind).elim
+      | forallE => exact (TShape.forallE_not_le_indTy hind).elim
+      | lam htm =>
+        unfold WShape.lam' at hind ⊢
+        split at hind <;> rename_i hnz
+        · exact (TShape.lam_not_le_indTy hind).elim
+        · simpa [hnz] using (LR Γ₀).bot htyped.isType
+      | ctor => exact (TShape.ctor_not_le_indTy hind).elim
+      | indTy =>
+        rw [LR_succ]
+        change LRS.IndTyHead Γ₀ (const c ls) ∧ LRS.IndTyHead Γ₀ (const c ls)
+        have hhead : LRS.IndTyHead Γ₀ (const c ls) :=
+          ⟨c, ls, [], by simpa using hcl, .rfl⟩
+        exact ⟨hhead, hhead⟩
+    | pat hpat hmatch hrhs =>
+      have hp := hmatch.nil_inv
+      subst hp
+      obtain ⟨value, closed, hr, hdefΓ, _⟩ :=
+        Params.Semantic.defn_whRed (Γ := Γ) hpat hreg hlen
+      subst hr
+      obtain ⟨value', closed', hr', hdef₀, hred₀⟩ :=
+        Params.Semantic.defn_whRed (Γ := Γ₀) hpat hreg hlen
+      cases hr'
+      cases hrhs with
+      | bot => exact (LR Γ₀).bot htyped.isType
+      | const hvalue =>
+        obtain ⟨m₁, hle₁, hr₁⟩ := hvalue
+        obtain ⟨nV, -, hstratV⟩ := hdefΓ.stratify
+        have adV : LR.Adequate Γ₀ Γ ρ (SExpr.mkInst ls value)
+            (SExpr.mkInst ls value) (SExpr.mkInst ls ci.type) mx bx := by
+          cases pR m₁ _ hr₁ with
+          | inl hall => exact (hall nV).1 hle₁ hstratV htyped hB
+          | inr hlocal =>
+            exact defnStep hpat hreg hlen (depth + 1)
+              (hR m₁ _ hr₁) hlocal (cR m₁ _ hr₁) lower hΓ₀
+              hle₁ hstratV htyped hB
+        have hredS : Γ₀ ⊢ .const c ls ⤳* SExpr.mkInst ls value :=
+          .tail .rfl hred₀
+        refine ((LR Γ₀).whr hredS hredS).2 ?_
+        have hv := (adV.1 W).1
+        simpa only [closed.mkInstS.subst_eq .zero,
+          (Params.henv.closedC hreg).mkInstS.subst_eq .zero] using hv
+
+/-- The complete constant self-adequacy producer, modulo the independently
+staged rank recursion and coherent iota leaf. -/
+theorem LR.SelfAdequateConstStep.of_deltaRank [Params.DeltaRank]
+    (hGamma : Ctx.WF Γ₀) (leafStep : LR.CoherentIotaLeafStep Γ₀)
+    (restart : ∀ c : Name,
+      LR.DeltaRankRestart Γ₀ (Params.DeltaRank.rank c)) :
+    LR.SelfAdequateConstStep Γ₀ :=
+  LR.SelfAdequateConstStep.of_steps hGamma leafStep
+    (LR.ConstDefnDeepInstStep.of_deltaRank restart)
+
+/-- Assemble the self-adequacy half of the coherent Nat algebra from its
+two remaining leaf-shaped obligations and the conversion callback. -/
+theorem LR.CoherentSelfStep.of_leafSteps
+    (hΓ₀ : Ctx.WF Γ₀)
+    (defeqStep : ∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth)
+    (leafStep : LR.CoherentIotaLeafStep Γ₀)
+    (defnStep : LR.ConstDefnDeepInstStep Γ₀) :
+    LR.CoherentSelfStep Γ₀ :=
+  LR.coherentSelfStep_of_steps defeqStep hΓ₀
+    (LR.SelfAdequateConstStep.of_steps hΓ₀ leafStep defnStep)
+
+/-- The same assembly against the strictly smaller definitional-unfold
+obligation.  Together with `MajorChainFoldStep` this is the current minimal
+hypothesis inventory of the coherent self-adequacy half. -/
+theorem LR.CoherentSelfStep.of_leafStepsDeep
+    (hΓ₀ : Ctx.WF Γ₀)
+    (defeqStep : ∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth)
+    (leafStep : LR.CoherentIotaLeafStep Γ₀)
+    (deepStep : LR.ConstDefnDeepStepR Γ₀) :
+    LR.CoherentSelfStep Γ₀ :=
+  LR.CoherentSelfStep.of_leafSteps hΓ₀ defeqStep leafStep
+    (LR.ConstDefnDeepInstStep.of_deepStepR deepStep)
+
+/-- Derivation induction once the recursive constructor-major leaf has been
+supplied explicitly.  This is the non-circular adequacy core used by the
+level-indexed joint construction. -/
+theorem LR.adequacy_of_iotaWitnessStep
+    (iotaStep : LR.IotaWitnessStep Γ₀)
+    (hΓ₀ : Ctx.WF Γ₀)
+    (H : IsDefEqStrong Γ M N A)
     (hM : LE_Interp ρ m.T M) (hA : LE_Interp ρ a.T A) (hmem : m.HasType a) :
     Adequate (n := n) Γ₀ Γ ρ M N A m a := by
-  replace H := H.strong; induction H generalizing ρ n m a with
+  induction H generalizing ρ n m a with
   | @bvar Γ i A _ h h2 ih =>
     refine .refl fun _ _ W => ?_; clear h2 ih
     have hle := LE_Interp.bvar_iff.1 hM; clear hM
@@ -118,21 +7933,9 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
       cases h with
       | zero => exact lift_subst ▸ (h0.2 a hA).2 (.bvar hle) hmem
       | succ h' => exact lift_subst ▸ ih h' (LE_Interp.weak_iff.1 hA) hle
-  | symm H ih => exact .fits fun W => (ih ((LE_Interp.sound H.defeq W).1.2 hM) hA hmem).symm
-  | trans _ H1 H2 ihA ih1 ih2 =>
-    exact .fits fun W => (ih1 hM hA hmem).trans (ih2 ((LE_Interp.sound H1.defeq W).1.1 hM) hA hmem)
-  | trans' H1 H2 ih1 ih2 =>
-    by_cases hm : m ≤ .bot; · exact WShape.le_bot.1 hm ▸ .bot hmem.isType
-    rename_i A B u C v
-    refine .fits fun W => ?_
-    refine (ih1 hM hA hmem).trans' (v := v) (r := v ≠ .zero) ?_
-    refine have ihs1 := LE_Interp.sound H1.defeq W; have hM₂ := ihs1.1.1 hM; ?_
-    have ihs2 := LE_Interp.sound H2.defeq W (m := m.T)
-    have ⟨a₂, s₂, b1, b2, b3, b4⟩ := ihs2.2 hM₂
-    replace b4 := TShape.HasType.sort.mono_r b3.le_sort b4
-    have := TShape.HasType.mono_r hA.le_sort .sort hmem.T
-    refine ih2 (ihs1.1.1 hM) (.sort TShape.sort_eqv.1) ?_
-    exact WShape.HasType.T_iff.1 <| .mono_r TShape.sort_eqv.2 .sort_T <| this.retype b4 b1
+  | symm H ih => exact .fits fun W => (ih ((LE_Interp.sound H W).1.2 hM) hA hmem).symm
+  | trans H1 H2 ih1 ih2 =>
+    exact .fits fun W => (ih1 hM hA hmem).trans (ih2 ((LE_Interp.sound H1 W).1.1 hM) hA hmem)
   | @sort _ l =>
     suffices (LR Γ₀).DefEq (.sort l) (.sort l) (.sort l.succ) m a from
       ⟨fun _ _ _ => ⟨this, this⟩, fun _ _ => this⟩
@@ -145,17 +7948,235 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
       · simp [WShape.ext_iff, WShape.forallE, WShape.sort, Shape.sort,
           WShape.lam', WShape.lam, WShape.bot, WShape.ctor, WShape.indTy,
           Shape.bot] at h <;> first | split at h <;> simp_all only [reduceCtorEq] | simp_all
-  | @const c ci Γ ls _ h1 h2 h3 =>
-    cases hM with | bot => exact .bot hmem.isType | const a1 _ a3 a4 a5 a6
-    cases h1.symm.trans a1
-    suffices ∀ {σ}, (LR Γ₀).DefEq (const c ls) (const c ls) (((mk ci.type).instL ls).subst σ) m a
-      from ⟨fun _ _ _ => ⟨this, this⟩, fun _ _ => this⟩
-    intro σ; rw [(Params.henv.closedC h1).mkS.instL.subst_eq .zero]; clear σ
-    sorry
-  | @appDF Γ A u F F' B X X' v _ Hf Ha HBa _ ihf iha ihBa =>
+  | @const c ci Γ ls u h1 h2 hTy F hF hDef ihTy ihF ihDef =>
+    -- Constant evaluation is derivation-sensitive: retain one constructor
+    -- tree so every reached `R` leaf uses its matching recursive callback.
+    cases hM.witness with
+    | bot => exact .bot hmem.isType
+    | @const _ _ ci' _ m' _ a' _ R hreg _ hle hm'ty hA' hConst hR =>
+      cases h1.symm.trans hreg
+      suffices ∀ {σ σ'}, LR.SubstWF Γ₀ σ σ' Γ ρ →
+          (LR Γ₀).DefEq (const c ls) (const c ls) ((mkInst ls ci.type).subst σ) m a
+        from ⟨fun _ _ W => ⟨this W, this W⟩, fun _ W => this W⟩
+      intro σ σ' W
+      rw [(Params.henv.closedC h1).mkInstS.subst_eq .zero]
+      have hC : LE_Interp.Const c ls (LE_Interp.Lower R) [] m.T :=
+        hConst.mono hle (fun le hr => ⟨_, le, hr⟩)
+      cases hC with
+      | bot => exact (LR Γ₀).bot hmem.isType
+      | lam hrec hlam =>
+        rename_i nsem hlen_sem fsem
+        cases hmem.unfold with
+        | bot hm => exact (LR Γ₀).bot hm
+        | sort => exact (TShape.sort_not_le_lam' hlam).elim
+        | forallE => exact (TShape.forallE_not_le_lam' hlam).elim
+        | @lam k f a₁ a₂ htm =>
+          obtain ⟨n', mTy, sTy, le_n, le_a, hTy', hSort, hmTy⟩ :=
+            (LE_Interp.sound hTy W.left.fits).2 hA |>.out
+          have hty' := (ihTy hTy' hSort hmTy).2 W.left
+          rw [(Params.henv.closedC h1).mkInstS.subst_eq .zero] at hty'
+          have hty : (LR Γ₀).TyDefEq (mkInst ls ci.type) (mkInst ls ci.type)
+              (.forallE a₁ a₂) :=
+            toValTy le_n le_a hmem.isType hSort hmTy hty'
+          rw [LR_succ] at hty ⊢
+          unfold WShape.lam'
+          split <;> rename_i hf
+          · obtain ⟨A₁, A₂, _, _, u₁, u₂, hred, _, hA₁, hA₂, hvalA₁, hpi⟩ := hty
+            refine (LRS.DefEq.lam_forallE (M := .const c ls) (N := .const c ls)
+              (A := mkInst ls ci.type) (f := f) (hf := hf) (a₁ := a₁) (a₂ := a₂)
+              (LR Γ₀)).2
+              ⟨A₁, A₂, u₁, u₂, hred, hA₁.leftType,
+                (LR Γ₀).left_ty hvalA₁, hA₂.leftType, LRS.PiDefEq.left hpi, ?_⟩
+            -- `hrec` is the semantic action of this constant.  Its child at
+            -- each related argument is the well-founded predecessor needed
+            -- to establish this `LamDefEq`; no type-shape work remains here.
+            have eval : ∀ {K : Nat}, K = k → ∀
+                {x y : SExpr} {p : WShape K} {x₀ y₀ : WShape nsem},
+                p.HasType (a₁.lift K) →
+                Γ₀ ⊢ x ≡ y : A₁ →
+                (LR Γ₀).DefEq x y A₁ p (a₁.lift K) →
+                (x₀, y₀) ∈ fsem → x₀.T ≤ p.T →
+                ((f.lift K).app p).T ≤ y₀.T →
+                (LR Γ₀).DefEq ((const c ls).app x) ((const c ls).app y)
+                  (A₂.inst x) ((f.lift K).app p) ((a₂.lift K).app p) := by
+              intro K hK
+              subst K
+              intro x y p x₀ y₀ hp hxy hv hmem₀ hx₀ hy₀
+              have hn : k ≤ k := Nat.le_refl k
+              have hPiK : LRS.PiDefEq (LR Γ₀) A₁ A₂ A₂
+                  (a₁.lift k) (a₂.lift k) :=
+                (LRS.PiDefEq.lift hn htm.1).2 (LRS.PiDefEq.left hpi)
+              have hAK : (LR Γ₀).TyDefEq (A₂.inst x) (A₂.inst x)
+                  ((a₂.lift k).app p) :=
+                hPiK.2 hp hxy.hasType.1 ((LR Γ₀).left hv)
+              have hout : ((f.lift k).app p).HasType ((a₂.lift k).app p) :=
+                (WShape.HasTypeLam.iff.1 ((WShape.HasTypeLam.lift hn).2 htm)).2.2 p hp
+              have hType₀ : Γ₀ ⊢ mkInst ls ci.type : .sort u := by
+                simpa only [(Params.henv.closedC h1).mkInstS.subst_eq .zero,
+                  SExpr.subst] using
+                  (hTy.subst W.left.toSubstEq).hasType.1
+              have hTypePi : Γ₀ ⊢
+                  mkInst ls ci.type ≡ .forallE A₁ A₂ : .sort u :=
+                hred.defeq hType₀
+              have hConstPi : Γ₀ ⊢ .const c ls : .forallE A₁ A₂ :=
+                hTypePi.defeqDF (.const h1 h2)
+              have hAppTerm : Γ₀ ⊢
+                  SExpr.app (SExpr.const c ls) x ≡
+                    SExpr.app (SExpr.const c ls) y : A₂.inst x :=
+                .appDF hConstPi hxy
+              have hAppType : Γ₀ ⊢ A₂.inst x : .sort u₂ :=
+                (IsDefEq.beta hA₂.leftType hxy.hasType.1).hasType.2
+              have hAppSpineX : SExpr.SpineWF Γ₀ (mkInst ls ci.type)
+                  [x] (A₂.inst x) := by
+                simpa only [List.nil_append] using
+                  (SExpr.SpineWF.nil (Γ := Γ₀) (A := mkInst ls ci.type)).snoc
+                    hTypePi hxy.hasType.1
+              obtain ⟨_, hAppCodomain⟩ := (hPiK.1 hp hxy hv).leftDefEq
+              have hAppSpineY : SExpr.SpineWF Γ₀ (mkInst ls ci.type)
+                  [y] (A₂.inst x) := by
+                have hspine :=
+                  (SExpr.SpineWF.nil (Γ := Γ₀) (A := mkInst ls ci.type)).snoc
+                    hTypePi hxy.hasType.2
+                exact SExpr.SpineWF.ret hspine hAppCodomain.symm
+              have hA₁K : (LR Γ₀).TyDefEq A₁ A₁ (a₁.lift k) :=
+                (LR.TyDefEq.lift hn
+                  (WShape.HasTypePi.iff.1 htm.1).1.isType).2
+                  ((LR Γ₀).left_ty hvalA₁)
+              let hAppPair : SExpr.SpineWF.LastPair Γ₀
+                  (mkInst ls ci.type) [] [] x y (A₂.inst x) := {
+                  prefixType := mkInst ls ci.type
+                  domain := A₁
+                  codomain := A₂
+                  piSort := u
+                  resultSortX := u₂
+                  resultSortY := _
+                  prefixX := .nil
+                  prefixY := .nil
+                  pi := hTypePi
+                  major := hxy
+                  resultX := hAppType
+                  resultY := hAppCodomain.symm }
+              have hAppAligned : LRS.CtorSpineDefEq (LR Γ₀)
+                  (mkInst ls ci.type) [x] [y] [p] (A₂.inst x) :=
+                .cons .nil hTypePi hp hA₁K hxy hv hAppCodomain.symm
+              have hAppLeaf : LR.PatternLeafSpine Γ₀ (LR Γ₀)
+                  (mkInst ls ci.type) [x] [y] [p] (A₂.inst x)
+                  ((f.lift k).app p) ((a₂.lift k).app p) := {
+                majorX := x
+                recXs := []
+                majorY := y
+                recYs := []
+                majorShape := p
+                recShapes := []
+                majorTypeShape := a₁.lift k
+                resultShape := f.lift k
+                resultTypeShape := a₂.lift k
+                args_eq := rfl
+                args'_eq := rfl
+                rargs_eq := rfl
+                out_eq := rfl
+                outTy_eq := rfl
+                pair := hAppPair
+                majorHasType := hp
+                resultType := (WShape.HasTypePi.lift hn).2 htm.1
+                majorType := hA₁K
+                majorRel := hv
+                aligned := hAppAligned
+                pi := hPiK }
+              have hRI : ∀ {m M}, R m M →
+                  LE_Interp.Witness ρ m M :=
+                fun hr => hR _ _ hr
+              have evalPat : LR.PatternLeafDefEqAt Γ₀ k c ls
+                  (LE_Interp.Lower R) :=
+                LR.PatternLeafDefEqAt.of_iota (iotaStep hΓ₀ hRI)
+              simpa only [List.foldr_cons, List.foldr_nil] using
+                LR.constDefEq (fun le hr => hr.mono le)
+                  (hrec x₀ y₀ hmem₀) evalPat
+                  (.cons hx₀ .nil) hAppLeaf
+                  hAppTerm ⟨u₂, hAppType⟩ (.const h1 h2) hAppSpineX hAppSpineY
+                  hout hAK hy₀
+            exact LR.constLamDefEq (hf := hf) (nArgs := 0) htm hlam
+              (fun {_ _ _ _ _} hp hxy hv hmem₀ hx₀ hy₀ =>
+                LogRel.DefEqRect.diagonal
+                  (eval (Nat.max_eq_left (Nat.zero_le k))
+                    hp hxy hv hmem₀ hx₀ hy₀))
+          · exact (LR Γ₀).bot hmem.isType
+        | ctor => exact (TShape.ctor_not_le_lam' hlam).elim
+        | indTy => exact (TShape.indTy_not_le_lam' hlam).elim
+      | ctor hcl hctor =>
+        cases hmem.unfold with
+        | bot hm => exact (LR Γ₀).bot hm
+        | sort => exact (TShape.sort_not_le_ctor' hctor).elim
+        | forallE => exact (TShape.forallE_not_le_ctor' hctor).elim
+        | lam htm =>
+          unfold WShape.lam' at hctor ⊢
+          split at hctor <;> rename_i hn
+          · exact (TShape.lam_not_le_ctor' hctor).elim
+          · simpa [hn] using (LR Γ₀).bot hmem.isType
+        | @ctor n c' l' h' =>
+          obtain ⟨hc, hl⟩ := TShape.ctor_le_ctor'_nil (by simpa using hcl) hctor
+          subst c'
+          subst l'
+          let cl : CtorBundle.IsCtor c := ⟨.ctor 0, by simpa using hcl, rfl⟩
+          let Fc := F cl
+          have hsort : LE_Interp ρ (WShape.type : WShape (n+1)).T (.sort Fc.u) := by
+            exact .sort (decide_eq_true Fc.hu0 ▸ TShape.sort_eqv.1)
+          have hty := (ihF cl hA hsort WShape.HasType.indTy).2 W.left
+          have hhead : LRS.IndTyHead Γ₀ (mkInst ls ci.type) := by
+            rw [(Params.henv.closedC h1).mkInstS.subst_eq .zero] at hty
+            simpa only [LR_succ, LRS.DefEq.sort_a, LRS.TyDefEq.indTy_m] using hty.1
+          rw [LR_succ]
+          change LRS.IndDefEq Γ₀ (LR Γ₀) (const c ls) (const c ls) (mkInst ls ci.type)
+            (WShape.ctor c [] h')
+          exact ⟨hhead, LRS.CtorDefEq.exact
+            (IH := LR Γ₀) (c := c) (rargs := [])
+            (M := const c ls) (N := const c ls)
+            (ls := ls) (ls' := ls) (args := []) (args' := [])
+            (by simpa using hcl) rfl rfl rfl .rfl .rfl
+            (.const h1 h2) (.const h1 h2)
+            (.nil (Γ := Γ₀) (A := mkInst ls ci.type))
+            (.nil (Γ := Γ₀) (A := mkInst ls ci.type)) .nil
+            (LRS.CtorSpineDefEq.nil
+              (IH := LR Γ₀) (Head := mkInst ls ci.type))
+            (LRS.CtorSpineDefEq.nil
+              (IH := LR Γ₀) (Head := mkInst ls ci.type))⟩
+        | indTy => exact (TShape.indTy_not_le_ctor' hctor).elim
+      | indTy hcl hind =>
+        cases hmem.unfold with
+        | bot hm => exact (LR Γ₀).bot hm
+        | sort => exact (TShape.sort_not_le_indTy hind).elim
+        | forallE => exact (TShape.forallE_not_le_indTy hind).elim
+        | lam htm =>
+          unfold WShape.lam' at hind ⊢
+          split at hind <;> rename_i hn
+          · exact (TShape.lam_not_le_indTy hind).elim
+          · simpa [hn] using (LR Γ₀).bot hmem.isType
+        | ctor => exact (TShape.ctor_not_le_indTy hind).elim
+        | indTy =>
+          rw [LR_succ]
+          change LRS.IndTyHead Γ₀ (const c ls) ∧ LRS.IndTyHead Γ₀ (const c ls)
+          have hhead : LRS.IndTyHead Γ₀ (const c ls) :=
+            ⟨c, ls, [], by simpa using hcl, .rfl⟩
+          exact ⟨hhead, hhead⟩
+      | @pat p r _ _ _ hpat hmatch hrhs =>
+        have hp : p = .const c := hmatch.nil_inv
+        subst p
+        obtain ⟨value, closed, hr, hdef, hred⟩ :=
+          Params.Semantic.defn_whRed (Γ := Γ₀) hpat h1 h2
+        subst r
+        cases hrhs with
+        | bot => exact (LR Γ₀).bot hmem.isType
+        | const hvalue =>
+          have hvalue' : LE_Interp ρ m.T (SExpr.mkInst ls value) :=
+            hvalue.realize (fun hr => (hR _ _ hr).toInterp)
+          simpa only [SExpr.subst, (Params.henv.closedC h1).mkInstS.subst_eq .zero] using
+            ((ihDef hpat hvalue' hA hmem).1 W).2
+  | @appDF Γ A u B v F F' X X' _ _ Hf Ha HBa _ _ ihf iha ihBa =>
     cases hM with | bot => exact .bot hmem.isType | @app _ nf_app f _ _ _ x hif hia le_m
     suffices ∀ {F F' X X' σ σ'}, SubstWF Γ₀ σ σ' Γ ρ →
-        Γ ⊢ F ≡ F' : A.forallE B → Γ ⊢ X ≡ X' : A → Γ ⊢ B.inst X ≡ B.inst X' : .sort v →
+        IsDefEqStrong Γ F F' (A.forallE B) →
+        IsDefEqStrong Γ X X' A →
+        IsDefEqStrong Γ (B.inst X) (B.inst X') (.sort v) →
         LE_Interp ρ f.T F → LE_Interp ρ x.T X → LE_Interp ρ a.T (B.inst X) →
         (∀ {n'} {mf af : WShape n'}, LE_Interp ρ mf.T F → LE_Interp ρ af.T (.forallE A B) →
           mf.HasType af → Adequate Γ₀ Γ ρ F F' (.forallE A B) mf af) →
@@ -165,21 +8186,22 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
           mb.HasType av → Adequate Γ₀ Γ ρ (B.inst X) (B.inst X') (.sort v) mb av) →
         (LR Γ₀).DefEq (.subst (.app F X) σ) (.subst (.app F' X') σ')
           (.subst (B.inst X) σ) m a by
-      refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => this W Hf.defeq Ha.defeq HBa.defeq hif hia hA ihf iha ihBa⟩
-      · refine this W Hf.defeq.hasType.1 Ha.defeq.hasType.1 HBa.defeq.hasType.1 hif hia hA ?_ ?_ ?_
+      refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => this W Hf Ha HBa hif hia hA ihf iha ihBa⟩
+      · refine this W (Hf.trans Hf.symm) (Ha.trans Ha.symm) (HBa.trans HBa.symm)
+          hif hia hA ?_ ?_ ?_
         · exact fun hf hPi hmf => (ihf hf hPi hmf).left
         · exact fun ha hA hma => (iha ha hA hma).left
         · exact fun hB hv hmb => (ihBa hB hv hmb).left
       · refine (LR _).conv ((LR _).symm_ty ?_) <| this W
-          Hf.defeq.hasType.2 Ha.defeq.hasType.2 HBa.defeq.hasType.2
-          ((LE_Interp.sound Hf.defeq W.fits).1.1 hif) ((LE_Interp.sound Ha.defeq W.fits).1.1 hia)
-          ((LE_Interp.sound HBa.defeq W.fits).1.1 hA)
+          (Hf.symm.trans Hf) (Ha.symm.trans Ha) (HBa.symm.trans HBa)
+          ((LE_Interp.sound Hf W.fits).1.1 hif) ((LE_Interp.sound Ha W.fits).1.1 hia)
+          ((LE_Interp.sound HBa W.fits).1.1 hA)
           (fun hf hPi hmf => ?_) (fun ha hA hma => ?_) (fun hB hv hmb => ?_)
-        · have ⟨_, _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HBa.defeq W.fits).2 hA |>.out
+        · have ⟨_, _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HBa W.fits).2 hA |>.out
           exact toValTy le le' hmem.isType iv hmb ((ihBa iB iv hmb).2 W.left)
-        · exact (ihf ((LE_Interp.sound Hf.defeq W.left.fits).1.2 hf) hPi hmf).symm.left
-        · exact (iha ((LE_Interp.sound Ha.defeq W.left.fits).1.2 ha) hA hma).symm.left
-        · exact (ihBa ((LE_Interp.sound HBa.defeq W.left.fits).1.2 hB) hv hmb).symm.left
+        · exact (ihf ((LE_Interp.sound Hf W.left.fits).1.2 hf) hPi hmf).symm.left
+        · exact (iha ((LE_Interp.sound Ha W.left.fits).1.2 ha) hA hma).symm.left
+        · exact (ihBa ((LE_Interp.sound HBa W.left.fits).1.2 hB) hv hmb).symm.left
     intro F F' X X' σ σ' W hF hX hBa hif hia hA ihf iha ihBa
     have ⟨_, mf, _, le_nf, le_mf, hf', hPi, hmf⟩ := (LE_Interp.sound hF W.left.fits).2 hif |>.out
     have Af := ihf hf' hPi hmf
@@ -239,7 +8261,8 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
           (valPi.2 hx'_a₁ (hX.subst W.toSubstEq).hasType.1 <| (LR _).left this)
           (valPi.1 hx'_a₁ (hX.subst W.toSubstEq) this).2
       · refine (hm0 ?_).elim; unfold WShape.lam'; simp_all
-  | @lamDF Γ A A' u B v body body' HA HB HBody _ ihA ihB ihBody =>
+  | @lamDF Γ A A' u B v body body' HA HB HB' HBody HBody'
+      ihA ihB _ ihBody _ =>
     suffices ∀ {X Y X' Y' σ σ'},
         LE_Interp ρ m.T (.lam X Y) → SubstWF Γ₀ σ σ' Γ ρ →
         (∀ {k np} {p : WShape np} {mb ab : WShape k},
@@ -251,8 +8274,8 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
       refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => this hM W fun _ => ihBody⟩
       · exact this hM W fun _ hMb hBb hmb => (ihBody hMb hBb hmb).left
       · refine this ?_ W fun W hMb' hBb hmb => ?_
-        · exact (LE_Interp.sound (.lamDF HA.defeq HBody.defeq) W.fits).1.1 hM
-        · exact (ihBody ((LE_Interp.sound HBody.defeq W).1.2 hMb') hBb hmb).symm.left
+        · exact (LE_Interp.sound (.lamDF HA HB HB' HBody HBody') W.fits).1.1 hM
+        · exact (ihBody ((LE_Interp.sound HBody W).1.2 hMb') hBb hmb).symm.left
     intro X Y X' Y' σ σ' hTerm W IH
     suffices ∀ n' b (f : WShapeFun _), n = n' + 1 → a ≍ (.forallE b f : WShape (n'+1)) →
         (LR Γ₀).DefEq (.subst (.lam X Y) σ) (.subst (.lam X' Y') σ')
@@ -270,13 +8293,13 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
     rintro k a₁ a₂ rfl ⟨⟩
     have ⟨_, aty, _⟩ := WShape.HasType.forallE_l.1 hmem.isType
     have hTypA : Γ₀ ⊢ A.subst σ : .sort u :=
-      HA.defeq.hasType.1.subst W.left.toSubstEq
+      (HA.subst W.left.toSubstEq).hasType.1
     have hTypB : A.subst σ :: Γ₀ ⊢ B.subst σ.lift : .sort v :=
-      HB.defeq.subst (W.left.toSubstEq.lift hTypA)
+      HB.subst (W.left.toSubstEq.lift HA.defeq.hasType.1)
     have hA1 := hA.forallE_inv.1
     have ⟨_, a', _, le_n, le_a, hA', hSort, hmem'⟩ :=
-      (LE_Interp.sound HA.defeq W.left.fits).2 hA1 |>.out
-    have cons := Adequate.cons ihA HA.defeq
+      (LE_Interp.sound HA W.left.fits).2 hA1 |>.out
+    have cons := Adequate.cons ihA HA
     obtain ⟨g, hg, htm⟩ := WShape.HasType.forallE_inv hmem
     unfold WShape.lam' at hg; split at hg <;> [skip; (subst hg; exact (LR _).bot hmem.isType)]
     rename_i hlam; subst hg
@@ -285,13 +8308,26 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
     refine ⟨A.subst σ, B.subst σ.lift, u, v, .rfl, hTypA, ?_, hTypB, ?_, ?_⟩
     · exact (LR Γ₀).left_ty <| toValTy le_n le_a aty.1.isType hSort hmem'
         ((ihA hA' hSort hmem').2 W.left)
-    · simp [LRS.PiDefEq, inst_lift_cons]
-      refine have := ?_; ⟨this, fun _ _ hp ha hv => this hp ha hv⟩
-      intro x x' p hp ha hv
-      have W' := cons hp hA1 ha hv W.left
-      have ⟨n', ab, _, le, le', iB, iv, hmb⟩ :=
-        (LE_Interp.sound HB.defeq W'.fits).2 (hA.forallE_inv'.2 p) |>.out
-      exact toValTy le le' (aty.2 _ hp).toType iv hmb ((ihB iB iv hmb).1 W').1
+    · simp only [LRS.PiDefEq]
+      have edge : ∀ {{x x' p}}, p.HasType a₁ →
+          Γ₀ ⊢ x ≡ x' : A.subst σ →
+          (LR Γ₀).DefEq x x' (A.subst σ) p a₁ →
+          LRS.PiInstDefEq (LR Γ₀) (B.subst σ.lift)
+            (B.subst σ.lift) x x' (a₂.app p) := by
+        intro x x' p hp ha hv
+        have W' := cons hp hA1 ha hv W.left
+        have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+          (LE_Interp.sound HB W'.fits).2 (hA.forallE_inv'.2 p) |>.out
+        have hsem : (LR Γ₀).TyDefEq
+            ((B.subst σ.lift).inst x) ((B.subst σ.lift).inst x') (a₂.app p) := by
+          simpa [inst_lift_cons] using
+            toValTy le le' (aty.2 _ hp).toType iv hmb ((ihB iB iv hmb).1 W').1
+        have hraw : Γ₀ ⊢
+            (B.subst σ.lift).inst x ≡ (B.subst σ.lift).inst x' : .sort v := by
+          simpa only [inst_lift_cons, SExpr.subst] using
+            (HB.substCongr W'.toSubstEq).1
+        exact ⟨hsem, hsem, ⟨v, hraw⟩, ⟨v, hraw⟩⟩
+      exact ⟨edge, fun _ _ hp ha hv => (edge hp ha hv).leftTy⟩
     have beta {X Y t : SExpr} {σ} : Γ₀ ⊢ .app (.lam (X.subst σ) (Y.subst σ.lift)) t ⤳*
         Y.subst (σ.cons t) := inst_lift_cons (x := t) ▸ .tail .rfl .beta
     refine ⟨fun x x' p hp ha hv => ?_, fun x p hp ha hv => ?_⟩
@@ -303,9 +8339,10 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
       constructor
       · exact ((LR Γ₀).whr beta beta).2 <| ((IH W'.fits).1 W').1
       · have vtAA' := toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').1 W).1
-        have ha' : Γ₀ ⊢ x ≡ x' : A.subst σ' := (HA.defeq.hasType.1.subst W.toSubstEq).defeqDF ha
+        have ha' : Γ₀ ⊢ x ≡ x' : A.subst σ' :=
+          ((HA.substCongr W.toSubstEq).1).defeqDF ha
         have hv' := (LR Γ₀).conv vtAA' hv
-        have ⟨n', _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HB.defeq W'.fits).2 hBb_sd |>.out
+        have ⟨n', _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HB W'.fits).2 hBb_sd |>.out
         have W2 := cons hp hA1 ha.hasType.1 ((LR Γ₀).left hv) W
         have vtBB := toValTy le le' (aty.2 _ hp).toType iv hmb ((ihB iB iv hmb).1 W2).1
         refine ((LR Γ₀).whr beta beta).2 <| (LR Γ₀).conv ((LR Γ₀).symm_ty vtBB) ?_
@@ -328,75 +8365,180 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
     | @forallE k a₂ a₁ r aty
     have aty := WShape.HasTypePi.iff.1 aty
     have hA1 := hM.forallE_inv.1
-    have cons := Adequate.cons ihA HA.defeq
+    have cons := Adequate.cons ihA HA
     refine ⟨fun σ σ' W => ?_, fun σ W => ?_⟩ <;> (
       have ⟨_, a', _, le_n, le_a, hA', hSort, hmem'⟩ :=
-        (LE_Interp.sound HA.defeq W.left.fits).2 hA1 |>.out
-      have HAAσ := HA.defeq.subst W.left.toSubstEq
-      have S' := W.toSubstEq.lift HAAσ.hasType.1)
-    · have HAσ := HA.defeq.hasType.1.subst W.toSubstEq
-      have HA'σ := HA.defeq.hasType.2.subst W.toSubstEq
+        (LE_Interp.sound HA W.left.fits).2 hA1 |>.out
+      have HAAσ := HA.subst W.left.toSubstEq
+      have S' := W.toSubstEq.lift HA.defeq.hasType.1)
+    · have HAσ := (HA.substCongr W.toSubstEq).1
+      have HA'σ := (HA.substCongr W.toSubstEq).2
       constructor
       · refine ⟨A.subst σ, body.subst σ.lift, A.subst σ', body.subst σ'.lift, u, v,
-          .rfl, .rfl, HAσ, HBody.defeq.hasType.1.subst S', ?_, ?_⟩
+          .rfl, .rfl, .single HAσ, .single (HBody.substCongr S').1, ?_, ?_⟩
         · exact toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').1 W).1
-        simp [LRS.PiDefEq, inst_lift_cons]
-        refine ⟨fun _ _ p hp ha hv => ?_, fun _ p hp ha hv => ?_⟩ <;>
-          have hB := hM.forallE_inv'.2 p <;> [constructor <;> [
-            have W' := cons hp hA1 ha hv W.left;
-            ( have := toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').1 W).1
-              have W' := cons hp hA1 (HAσ.defeqDF ha) ((LR Γ₀).conv this hv) W.symm.left )];
-            have W' := cons hp hA1 ha.hasType.1 ((LR Γ₀).left hv) W] <;>
-        · have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
-            (LE_Interp.sound HBody.defeq W'.fits).2 hB |>.out
-          exact toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 W').1
+        simp only [LRS.PiDefEq]
+        constructor
+        · intro x x' p hp ha hv
+          have hB := hM.forallE_inv'.2 p
+          have WL := cons hp hA1 ha hv W.left
+          have ⟨_, _, _, leL, leL', iBL, ivL, hmbL⟩ :=
+            (LE_Interp.sound HBody WL.fits).2 hB |>.out
+          have semL : (LR Γ₀).TyDefEq
+              ((body.subst σ.lift).inst x) ((body.subst σ.lift).inst x')
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy leL leL' (aty.2 _ hp).toType ivL hmbL
+                ((ihBody iBL ivL hmbL).1 WL).1
+          have valA := toValTy le_n le_a aty.1.isType hSort hmem'
+            ((ihA hA' hSort hmem').1 W).1
+          have WR := cons hp hA1 (HAσ.defeqDF ha) ((LR Γ₀).conv valA hv)
+            W.symm.left
+          have ⟨_, _, _, leR, leR', iBR, ivR, hmbR⟩ :=
+            (LE_Interp.sound HBody WR.fits).2 hB |>.out
+          have semR : (LR Γ₀).TyDefEq
+              ((body.subst σ'.lift).inst x) ((body.subst σ'.lift).inst x')
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy leR leR' (aty.2 _ hp).toType ivR hmbR
+                ((ihBody iBR ivR hmbR).1 WR).1
+          have rawL : Γ₀ ⊢
+              (body.subst σ.lift).inst x ≡ (body.subst σ.lift).inst x' : .sort v := by
+            simpa only [inst_lift_cons, SExpr.subst] using
+              (HBody.substCongr WL.toSubstEq).1
+          have rawR : Γ₀ ⊢
+              (body.subst σ'.lift).inst x ≡ (body.subst σ'.lift).inst x' : .sort v := by
+            simpa only [inst_lift_cons, SExpr.subst] using
+              (HBody.substCongr WR.toSubstEq).1
+          exact ⟨semL, semR, ⟨v, rawL⟩, ⟨v, rawR⟩⟩
+        · intro x p hp ha hv
+          have hB := hM.forallE_inv'.2 p
+          have WX := cons hp hA1 ha.hasType.1 ((LR Γ₀).left hv) W
+          have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+            (LE_Interp.sound HBody WX.fits).2 hB |>.out
+          have hout : (LR Γ₀).TyDefEq
+              ((body.subst σ.lift).inst x) ((body.subst σ'.lift).inst x)
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 WX).1
+          exact cast (by congr 1) hout
       · refine ⟨A'.subst σ, body'.subst σ.lift, A'.subst σ', body'.subst σ'.lift, u, v,
-          .rfl, .rfl, HA'σ, HAAσ.defeqDF_l (HBody.defeq.hasType.2.subst S'), ?_, ?_⟩
+          .rfl, .rfl, .single HA'σ,
+          .single (HAAσ.defeqDF_l (HBody.substCongr S').2), ?_, ?_⟩
         · exact toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').1 W).2
-        simp [LRS.PiDefEq, inst_lift_cons]
-        have := toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').2 W.left)
-        refine ⟨fun _ _ p hp ha hv => ?_, fun _ p hp ha hv => ?_⟩ <;> (
-          have hv := (LR Γ₀).conv ((LR Γ₀).symm_ty this) hv
-          have ha := HAAσ.symm.defeqDF ha
-          have hB := hM.forallE_inv'.2 p) <;> [constructor <;> [
-            have W' := cons hp hA1 ha hv W.left;
-            ( have := toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').1 W).1
-              have W' := cons hp hA1 (HAσ.defeqDF ha) ((LR Γ₀).conv this hv) W.symm.left )];
-            have W' := cons hp hA1 ha ((LR Γ₀).left hv) W] <;>
-        · have ⟨_, _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HBody.defeq W'.fits).2 hB |>.out
-          exact toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 W').2
+        simp only [LRS.PiDefEq]
+        have valA' := toValTy le_n le_a aty.1.isType hSort hmem'
+          ((ihA hA' hSort hmem').2 W.left)
+        constructor
+        · intro x x' p hp ha hv
+          have ha₀ := HAAσ.symm.defeqDF ha
+          have hv₀ := (LR Γ₀).conv ((LR Γ₀).symm_ty valA') hv
+          have hB := hM.forallE_inv'.2 p
+          have WL := cons hp hA1 ha₀ hv₀ W.left
+          have ⟨_, _, _, leL, leL', iBL, ivL, hmbL⟩ :=
+            (LE_Interp.sound HBody WL.fits).2 hB |>.out
+          have semL : (LR Γ₀).TyDefEq
+              ((body'.subst σ.lift).inst x) ((body'.subst σ.lift).inst x')
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy leL leL' (aty.2 _ hp).toType ivL hmbL
+                ((ihBody iBL ivL hmbL).1 WL).2
+          have valA := toValTy le_n le_a aty.1.isType hSort hmem'
+            ((ihA hA' hSort hmem').1 W).1
+          have WR := cons hp hA1 (HAσ.defeqDF ha₀) ((LR Γ₀).conv valA hv₀)
+            W.symm.left
+          have ⟨_, _, _, leR, leR', iBR, ivR, hmbR⟩ :=
+            (LE_Interp.sound HBody WR.fits).2 hB |>.out
+          have semR : (LR Γ₀).TyDefEq
+              ((body'.subst σ'.lift).inst x) ((body'.subst σ'.lift).inst x')
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy leR leR' (aty.2 _ hp).toType ivR hmbR
+                ((ihBody iBR ivR hmbR).1 WR).2
+          have rawL : Γ₀ ⊢
+              (body'.subst σ.lift).inst x ≡ (body'.subst σ.lift).inst x' : .sort v := by
+            simpa only [inst_lift_cons, SExpr.subst] using
+              (HBody.substCongr WL.toSubstEq).2
+          have rawR : Γ₀ ⊢
+              (body'.subst σ'.lift).inst x ≡ (body'.subst σ'.lift).inst x' : .sort v := by
+            simpa only [inst_lift_cons, SExpr.subst] using
+              (HBody.substCongr WR.toSubstEq).2
+          exact ⟨semL, semR, ⟨v, rawL⟩, ⟨v, rawR⟩⟩
+        · intro x p hp ha hv
+          have ha₀ := HAAσ.symm.defeqDF ha
+          have hv₀ := (LR Γ₀).conv ((LR Γ₀).symm_ty valA') hv
+          have hB := hM.forallE_inv'.2 p
+          have WX := cons hp hA1 ha₀ ((LR Γ₀).left hv₀) W
+          have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+            (LE_Interp.sound HBody WX.fits).2 hB |>.out
+          have hout : (LR Γ₀).TyDefEq
+              ((body'.subst σ.lift).inst x) ((body'.subst σ'.lift).inst x)
+              (a₂.app p) := by
+            simpa [inst_lift_cons] using
+              toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 WX).2
+          exact cast (by congr 1) hout
     · refine ⟨A.subst σ, body.subst σ.lift, A'.subst σ, body'.subst σ.lift, u, v,
-        .rfl, .rfl, HAAσ, HBody.defeq.subst S', ?_, ?_⟩
+        .rfl, .rfl, .single HAAσ, .single (HBody.subst S'), ?_, ?_⟩
       · exact toValTy le_n le_a aty.1.isType hSort hmem' ((ihA hA' hSort hmem').2 W)
-      simp [LRS.PiDefEq, inst_lift_cons]
-      refine ⟨fun _ _ p hp ha hv => ?_, fun _ p hp ha hv => ?_⟩ <;> (
+      simp only [LRS.PiDefEq]
+      constructor
+      · intro x x' p hp ha hv
         have hB := hM.forallE_inv'.2 p
         have W' := cons hp hA1 ha hv W
-        have ⟨_, _, _, le, le', iB, iv, hmb⟩ := (LE_Interp.sound HBody.defeq W'.fits).2 hB |>.out)
-      · exact ⟨toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 W').1,
-               toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).1 W').2⟩
-      · exact toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).2 W')
+        have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+          (LE_Interp.sound HBody W'.fits).2 hB |>.out
+        have sem := (ihBody iB iv hmb).1 W'
+        have semL : (LR Γ₀).TyDefEq
+            ((body.subst σ.lift).inst x) ((body.subst σ.lift).inst x')
+            (a₂.app p) := by
+          simpa [inst_lift_cons] using
+            toValTy le le' (aty.2 _ hp).toType iv hmb sem.1
+        have semR : (LR Γ₀).TyDefEq
+            ((body'.subst σ.lift).inst x) ((body'.subst σ.lift).inst x')
+            (a₂.app p) := by
+          simpa [inst_lift_cons] using
+            toValTy le le' (aty.2 _ hp).toType iv hmb sem.2
+        have hraw := HBody.substCongr W'.toSubstEq
+        have rawL : Γ₀ ⊢
+            (body.subst σ.lift).inst x ≡ (body.subst σ.lift).inst x' : .sort v := by
+          simpa only [inst_lift_cons, SExpr.subst] using hraw.1
+        have rawR : Γ₀ ⊢
+            (body'.subst σ.lift).inst x ≡ (body'.subst σ.lift).inst x' : .sort v := by
+          simpa only [inst_lift_cons, SExpr.subst] using hraw.2
+        exact ⟨semL, semR, ⟨v, rawL⟩, ⟨v, rawR⟩⟩
+      · intro x p hp ha hv
+        have hB := hM.forallE_inv'.2 p
+        have W' := cons hp hA1 ha hv W
+        have ⟨_, _, _, le, le', iB, iv, hmb⟩ :=
+          (LE_Interp.sound HBody W'.fits).2 hB |>.out
+        have hout : (LR Γ₀).TyDefEq
+            ((body.subst σ.lift).inst x) ((body'.subst σ.lift).inst x)
+            (a₂.app p) := by
+          simpa [inst_lift_cons] using
+            toValTy le le' (aty.2 _ hp).toType iv hmb ((ihBody iB iv hmb).2 W')
+        exact cast (by congr 1) hout
   | @defeqDF Γ A' B' u' _ _ Hty He ihTy ihE =>
     have tyConv {σ} (W : SubstWF Γ₀ σ σ Γ ρ) :=
-      have hA' := (LE_Interp.sound Hty.defeq W.fits).1.2 hA
+      have hA' := (LE_Interp.sound Hty W.fits).1.2 hA
       have ⟨_, a', _, le_n, le_a, hA'', hSort, hmem'⟩ :=
-        (LE_Interp.sound Hty.defeq W.fits).2 hA' |>.out
+        (LE_Interp.sound Hty W.fits).2 hA' |>.out
       toValTy le_n le_a hmem.isType hSort hmem' ((ihTy hA'' hSort hmem').2 W)
     refine ⟨fun σ σ' W => ?_, fun σ W => ?_⟩ <;>
-      have hA' := (LE_Interp.sound Hty.defeq W.left.fits).1.2 hA
+      have hA' := (LE_Interp.sound Hty W.left.fits).1.2 hA
     · exact ⟨(LR Γ₀).conv (tyConv W.left) ((ihE hM hA' hmem).1 W).1,
              (LR Γ₀).conv (tyConv W.left) ((ihE hM hA' hmem).1 W).2⟩
     · exact (LR Γ₀).conv (tyConv W) ((ihE hM hA' hmem).2 W)
   | beta He Ha Happ Hinst _ihe _iha ihapp ihinst =>
     refine ⟨fun _ _ W => ⟨?_, ?_⟩, fun σ W => ?_⟩
     · exact ((ihapp hM hA hmem).1 W).1
-    · exact ((ihinst ((LE_Interp.sound (.beta He.defeq Ha.defeq) W.fits).1.1 hM) hA hmem).1 W).2
+    · exact ((ihinst ((LE_Interp.sound (.beta He Ha Happ Hinst) W.fits).1.1 hM)
+        hA hmem).1 W).2
     · exact ((LR _).whr .rfl (subst_inst ▸ .tail .rfl .beta)).1 ((ihapp hM hA hmem).2 W)
   | @eta _ e0 A0 B0 He Hlam ihe ihlam =>
     refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => ?_⟩
     · exact ((ihlam hM hA hmem).1 W).1
-    · exact ((ihe ((LE_Interp.sound (.eta He.defeq) W.fits).1.1 hM) hA hmem).1 W).2
-    have hM' := (LE_Interp.sound (.eta He.defeq) W.fits).1.1 hM
+    · exact ((ihe ((LE_Interp.sound (.eta He Hlam) W.fits).1.1 hM) hA hmem).1 W).2
+    have hM' := (LE_Interp.sound (.eta He Hlam) W.fits).1.1 hM
     cases hmem.unfold with
     | bot hm => exact (LR _).bot hm
     | sort => cases n <;> let .lam _ _ _ h := hM <;> cases TShape.sort_not_le_lam' h
@@ -416,58 +8558,302 @@ theorem LR.adequacy (H : Γ ⊢ M ≡ N : A)
     rw [inst_lift_cons, subst, lift_subst_cons]; rfl
   | proofIrrel Hp =>
     refine .fits fun W => ?_
-    have ⟨_, _, s, le_n, le_a, _, hSort, hmem'⟩ := (LE_Interp.sound Hp.defeq W).2 hA |>.out
+    have ⟨_, _, s, le_n, le_a, _, hSort, hmem'⟩ := (LE_Interp.sound Hp W).2 hA |>.out
     have hS := WShape.HasType.mono_r hSort.le_sort' .sort hmem'; simp at hS
     have ha' := hS.mono_r ((TShape.LE.lift_l le_n).1 le_a) ((WShape.HasType.lift le_n).2 hmem)
     cases (WShape.lift_eq_bot le_n).1 (hS.proofIrrel ha')
     exact .bot hmem.isType
-  | extra h1 h2 Hl Hr ihl ihr =>
+  | @defn c ci Γ ls u r hreg hlen hTy F hF action hRhs
+      ihTy ihF ihRhs =>
+    let Hdef : IsDefEqStrong Γ (.const c ls)
+        (r.1.applyS ls Empty.elim) (SExpr.mkInst ls ci.type) :=
+      .defn hreg hlen hTy F hF action hRhs
+    have hlocal : WHRed Γ (.const c ls) (r.1.applyS ls Empty.elim) :=
+      .extra action
+    refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => ?_⟩
+    · have hRhsInterp := (LE_Interp.sound Hdef W.fits).1.1 hM
+      have hAdeq := ihRhs hRhsInterp hA hmem
+      have hredL := hlocal.subst W.left.toSubstEq.left
+      have hredR := hlocal.subst W.symm.left.toSubstEq.left
+      exact ((LR Γ₀).whr (.tail .rfl hredL) (.tail .rfl hredR)).2
+        (hAdeq.1 W).1
+    · have hRhsInterp := (LE_Interp.sound Hdef W.fits).1.1 hM
+      exact (ihRhs hRhsInterp hA hmem).1 W |>.2
+    · have hRhsInterp := (LE_Interp.sound Hdef W.fits).1.1 hM
+      have hAdeq := ihRhs hRhsInterp hA hmem
+      have hred := hlocal.subst W.toSubstEq.left
+      exact ((LR Γ₀).whr (.tail .rfl hred) .rfl).2 (hAdeq.2 W)
+  | extra action Hl Hr ihl ihr =>
     refine ⟨fun σ σ' W => ⟨?_, ?_⟩, fun σ W => ?_⟩
     · exact ((ihl hM hA hmem).1 W).1
-    · exact ((ihr ((LE_Interp.sound (.extra h1 h2) W.fits).1.1 hM) hA hmem).1 W).2
-    · have ⟨⟨hA1, _⟩, hA2, hA3⟩ := Params.henv.closed.2 h1
-      have := (ihl hM hA hmem).2 W; revert this
-      rw [hA1.mkS.instL.subst_eq .zero, hA2.mkS.instL.subst_eq .zero, hA3.mkS.instL.subst_eq .zero]
-      let ⟨_, _, _, _, _, a1, a2, a3, a4, a5⟩ := Params.extra_pat Γ₀ h1 h2
-      exact ((LR _).whr .rfl (.tail .rfl (a5 ▸ .extra a1 a2 a3 a4))).1
-
-theorem forallE_whRed_l (d : Γ ⊢ A₀ ≡ SExpr.forallE B₁ F₁ : .sort s) :
+    · exact ((ihr ((LE_Interp.sound
+        (.extra action Hl Hr) W.fits).1.1 hM)
+        hA hmem).1 W).2
+    · have hself := (ihl hM hA hmem).2 W
+      have hlocal := SExpr.WHRed.extra action
+      have hred := hlocal.subst W.toSubstEq.left
+      exact ((LR _).whr .rfl (.tail .rfl hred)).1 hself
+
+/-- The depth bootstrap.  Every contextual adequacy rung follows by strong
+Nat induction on stratified typing depth once each rung's joint leaf is
+supplied as an `IotaWitnessStepAtDepth` hypothesis.  The induction adds
+nothing of its own at a rung: it hands the strict predecessor family to
+the leaf obligation unchanged and runs the derivation induction
+`adequacy_of_iotaWitnessStep` with the resulting leaf.  In particular no
+predecessor inversion or uniqueness package is assembled here; turning
+the supplied family into such packages is the leaf producer's decision
+(`JointStratifiedPathInversionAt.of_predecessorAdequacy`,
+`SelfAdequateDefeqStepAt.of_lowerAdequacy`).
+
+The stratification certificate of the rung being produced is deliberately
+not offered to the leaf: the derivation induction is depth-blind, so a
+root certificate cannot bound the leaf instances reached through `trans`
+or evaluator descent.  Whatever depth bound a leaf producer needs must
+come from its own registered-rule certificates. -/
+theorem LR.contextualAdequacyAtDepth_of_iotaSteps
+    (steps : ∀ d, LR.ContextualIotaWitnessStepAtDepth d) :
+    ∀ d, LR.ContextualAdequacyAtDepth d := by
+  intro d
+  induction d using Nat.strongRecOn with
+  | ind d ih =>
+    intro Γ₀ hΓ₀
+    intro n Γ ρ M N A B core m a H _hstrat hM hA hmem
+    exact LR.adequacy_of_iotaWitnessStep (steps d ih) hΓ₀ H hM hA hmem
+
+/-- Contextual adequacy at every shape level from the complete depth
+tower: a strong equality stratifies its left endpoint at some finite
+depth (`IsDefEqStrong.stratify`), and the heterogeneous rung at that
+depth subsumes the level-indexed statement.  This is the only assembly
+the level-indexed packages still require; the level tower survives as a
+facade over the depth fixpoint. -/
+theorem LR.contextualAdequacyAt_of_adequacyAtDepth
+    (tower : ∀ d, LR.ContextualAdequacyAtDepth d) (n : Nat) :
+    LR.ContextualAdequacyAt n := by
+  intro Γ₀ hΓ₀
+  intro Γ ρ M N A m a H hM hA hmem
+  obtain ⟨d, hstrat, _⟩ := H.stratify
+  exact tower d hΓ₀ H hstrat hM hA hmem
+
+/-- End-to-end conditional form of the depth bootstrap: the complete
+depth-indexed leaf family yields every level-indexed contextual adequacy
+package. -/
+theorem LR.contextualAdequacyAt_of_iotaSteps
+    (steps : ∀ d, LR.ContextualIotaWitnessStepAtDepth d) (n : Nat) :
+    LR.ContextualAdequacyAt n :=
+  LR.contextualAdequacyAt_of_adequacyAtDepth
+    (LR.contextualAdequacyAtDepth_of_iotaSteps steps) n
+
+/-- The active joint-leaf obligation.  Its body is intentionally isolated
+from `adequacy_of_iotaWitnessStep`: completing it may consume only the
+well-founded fixed-head and predecessor-uniqueness packages, never the final
+polymorphic adequacy theorem. -/
+theorem LR.iotaWitnessStep : LR.IotaWitnessStep Γ₀ := by
+  intro hΓ₀ ρ c ls R hR
+  intro nI rargsI rec major ctor arity rI mcapI
+    xsI ysI CHeadI AI outI outTyI hpatI hmatchI hrhsI hleafI
+    htermI hAIType hheadI hspineXI hspineYI houtI hAI
+  cases hmatchI with
+  | @app fPat nCtor head recShapes mrec aPat ctorHead
+      ctorShapes mctor hmfI hmaI =>
+    rcases hleafI with
+      ⟨majorX, recXs, majorY, recYs, majorShape, recShapesI,
+        majorTypeShape, resultShape, resultTypeShape,
+        hxs, hys, hrargs, houtEq, houtTyEq, hlastPair,
+        hpMajor, hresultType, htyMajor, hvMajor, halignedI, hPiI⟩
+    subst xsI
+    subst ysI
+    simp only [List.cons.injEq] at hrargs
+    rcases hrargs with ⟨hmajorShape, hrecShapes⟩
+    subst majorShape
+    subst recShapesI
+    subst outI
+    subst outTyI
+    have hctorHead : ctor = ctorHead := hmaI.varN_const_head
+    subst ctorHead
+    have hctorClass : Params.classify ctor =
+        some (.ctor ctorShapes.reverse.length) := by
+      simpa using hmaI.head_wf_eq (Params.pat_wf hpatI).2
+    have hmajorCtor := LR.DefEq.ctor'_inv hctorClass hpMajor hvMajor
+    have hrecargsI : LRS.CtorArgsDefEq (LR Γ₀)
+        recXs recYs recShapes :=
+      halignedI.args.tail
+    sorry
+
+/-- Main adequacy theorem, now a thin consumer of the isolated joint leaf. -/
+theorem LR.adequacy (H : IsDefEqStrong Γ M N A)
+    (hΓ₀ : Ctx.WF Γ₀)
+    (hM : LE_Interp ρ m.T M) (hA : LE_Interp ρ a.T A)
+    (hmem : m.HasType a) :
+    Adequate (n := n) Γ₀ Γ ρ M N A m a :=
+  LR.adequacy_of_iotaWitnessStep LR.iotaWitnessStep hΓ₀ H hM hA hmem
+
+/-- The polymorphic theorem supplies each individual level package.  Keeping
+this adapter separate is what lets the joint proof replace it with the
+strictly earlier package during well-founded recursion. -/
+theorem LR.adequacyAt (Γ₀ : List SExpr) (hΓ₀ : Ctx.WF Γ₀) (n : Nat) :
+    LR.AdequacyAt Γ₀ n :=
+  fun H hM hA hmem => LR.adequacy H hΓ₀ hM hA hmem
+
+/-- Pi-head inversion from adequacy at one positive shape level.  Domain and
+codomain conversions are retained as paths because the weak judgment does
+not yet identify the universe assigned to an intermediate type. -/
+theorem forallE_whRed_l_of_adequacy
+    {n : Nat} (adequacy : LR.AdequacyAt Γ (n + 1))
+    (d : IsDefEqStrong Γ A₀ (SExpr.forallE B₁ F₁) (.sort s)) :
     ∃ B₀ F₀, Γ ⊢ A₀ ⤳* .forallE B₀ F₀ ∧ ∃ u v,
-      Γ ⊢ B₀ ≡ B₁ : .sort u ∧ B₀::Γ ⊢ F₀ ≡ F₁ : .sort v := by
-  have hPi : LE_Interp .nil (WShape.T (n := 1) (.forallE .bot WShapeFun.bot)) (.forallE B₁ F₁) := by
+      TypeDefEqPath Γ B₀ B₁ u ∧ TypeDefEqPath (B₀ :: Γ) F₀ F₁ v := by
+  have hPi : LE_Interp .nil
+      (WShape.T (n := n + 1) (.forallE (.bot : WShape n) WShapeFun.bot))
+      (.forallE B₁ F₁) := by
     refine .forallE' .bot .bot (.bot <| .bot' .sort) fun _ h => ?_
     cases h.bot_r; exact WShapeFun.bot_app.symm ▸ .bot
-  have hmem : WShape.HasType (n := 1) (.forallE .bot WShapeFun.bot) (.sort (s ≠ .zero)) := by
+  have hmem : WShape.HasType (n := n + 1)
+      (.forallE (.bot : WShape n) WShapeFun.bot) (.sort (s ≠ .zero)) := by
     refine WShape.HasType.forallE_l.2 ⟨_, ?_, rfl⟩
     refine WShape.HasTypePi.iff.2 ⟨.bot (.bot' .sort), fun x hx => ?_⟩
     cases WShape.HasType.bot_r hx; exact WShapeFun.bot_app.symm ▸ .bot .sort
-  have := (LR.adequacy d ((LE_Interp.sound d .nil).1.2 hPi) (.sort TShape.sort_eqv.1) hmem).2 .id
+  have := (adequacy d ((LE_Interp.sound d .nil).1.2 hPi)
+    (.sort TShape.sort_eqv.1) hmem).2 .id
   have ⟨_, _, _, _, _, _, redA₀, redPi, convB, convF, _⟩ := subst_id ▸ subst_id ▸ subst_id ▸ this
   cases WHNF.forallE.whRedS redPi; exact ⟨_, _, redA₀, _, _, convB, convF⟩
 
+theorem forallE_whRed_l
+    (hΓ : Ctx.WF Γ)
+    (d : IsDefEqStrong Γ A₀ (SExpr.forallE B₁ F₁) (.sort s)) :
+    ∃ B₀ F₀, Γ ⊢ A₀ ⤳* .forallE B₀ F₀ ∧ ∃ u v,
+      TypeDefEqPath Γ B₀ B₁ u ∧ TypeDefEqPath (B₀ :: Γ) F₀ F₁ v :=
+  forallE_whRed_l_of_adequacy (n := 0) (LR.adequacyAt Γ hΓ 1) d
+
+/-- Collapse path-valued Pi-head inversion using contextual raw type
+uniqueness.  The domain path supplies the typing needed to establish that
+the extended binder context is well formed before the codomain path is
+collapsed. -/
+theorem forallE_whRed_l_of_adequacy_collapsed
+    {n : Nat} (adequacy : LR.AdequacyAt Γ (n + 1))
+    (uniq : LogRel.ContextualRawTypeUniq) (hΓ : Ctx.WF Γ)
+    (d : IsDefEqStrong Γ A₀ (SExpr.forallE B₁ F₁) (.sort s)) :
+    ∃ B₀ F₀, Γ ⊢ A₀ ⤳* .forallE B₀ F₀ ∧ ∃ u v,
+      Γ ⊢ B₀ ≡ B₁ : .sort u ∧ B₀ :: Γ ⊢ F₀ ≡ F₁ : .sort v := by
+  obtain ⟨B₀, F₀, hred, u, v, hB, hF⟩ :=
+    forallE_whRed_l_of_adequacy adequacy d
+  have hB' := hB.collapse (uniq hΓ)
+  have hBΓ : Ctx.WF (B₀ :: Γ) := ⟨hΓ, ⟨u, hB.leftType⟩⟩
+  exact ⟨B₀, F₀, hred, u, v, hB', hF.collapse (uniq hBΓ)⟩
+
 /-- Pi–Pi injectivity: if two Pi types are definitionally equal,
 their domains and codomains are each definitionally equal. -/
-theorem forallE_inv (H : Γ ⊢ SExpr.forallE A₀ B₀ ≡ SExpr.forallE A₁ B₁ : .sort s) :
-    ∃ u v, Γ ⊢ A₀ ≡ A₁ : .sort u ∧ A₀::Γ ⊢ B₀ ≡ B₁ : .sort v := by
-  have ⟨_, _, red, H⟩ := forallE_whRed_l H
+theorem forallE_inv_of_adequacy
+    {n : Nat} (adequacy : LR.AdequacyAt Γ (n + 1))
+    (H : IsDefEqStrong Γ (SExpr.forallE A₀ B₀) (SExpr.forallE A₁ B₁) (.sort s)) :
+    ∃ u v, TypeDefEqPath Γ A₀ A₁ u ∧
+      TypeDefEqPath (A₀ :: Γ) B₀ B₁ v := by
+  have ⟨_, _, red, H⟩ := forallE_whRed_l_of_adequacy adequacy H
   cases WHNF.forallE.whRedS red; exact H
 
-theorem sort_forallE_inv : ¬Γ ⊢ .sort u ≡ SExpr.forallE A₁ B₁ : .sort s :=
-  fun H => have ⟨_, _, H⟩ := forallE_whRed_l H; nomatch WHNF.sort.whRedS H.1
+theorem forallE_inv
+    (hΓ : Ctx.WF Γ)
+    (H : IsDefEqStrong Γ (SExpr.forallE A₀ B₀) (SExpr.forallE A₁ B₁) (.sort s)) :
+    ∃ u v, TypeDefEqPath Γ A₀ A₁ u ∧
+      TypeDefEqPath (A₀ :: Γ) B₀ B₁ v :=
+  forallE_inv_of_adequacy (n := 0) (LR.adequacyAt Γ hΓ 1) H
+
+/-- Ordinary Pi injectivity recovered from the path-valued adequacy result
+at the precise contextual-uniqueness boundary. -/
+theorem forallE_inv_of_adequacy_collapsed
+    {n : Nat} (adequacy : LR.AdequacyAt Γ (n + 1))
+    (uniq : LogRel.ContextualRawTypeUniq) (hΓ : Ctx.WF Γ)
+    (H : IsDefEqStrong Γ (SExpr.forallE A₀ B₀)
+      (SExpr.forallE A₁ B₁) (.sort s)) :
+    ∃ u v, Γ ⊢ A₀ ≡ A₁ : .sort u ∧
+      A₀ :: Γ ⊢ B₀ ≡ B₁ : .sort v := by
+  obtain ⟨_, _, hred, hInv⟩ :=
+    forallE_whRed_l_of_adequacy_collapsed adequacy uniq hΓ H
+  cases WHNF.forallE.whRedS hred
+  exact hInv
+
+theorem sort_forallE_inv_of_adequacy
+    {n : Nat} (adequacy : LR.AdequacyAt Γ (n + 1)) :
+    ¬IsDefEqStrong Γ (.sort u) (SExpr.forallE A₁ B₁) (.sort s) :=
+  fun H => have ⟨_, _, H⟩ := forallE_whRed_l_of_adequacy adequacy H
+    nomatch WHNF.sort.whRedS H.1
+
+theorem sort_forallE_inv (hΓ : Ctx.WF Γ) :
+    ¬IsDefEqStrong Γ (.sort u) (SExpr.forallE A₁ B₁) (.sort s) :=
+  sort_forallE_inv_of_adequacy (n := 0) (LR.adequacyAt Γ hΓ 1)
 
 /-- Sort injectivity: if two sorts are definitionally equal, their levels are equal. -/
-theorem sort_inv (d : Γ ⊢ SExpr.sort u ≡ SExpr.sort v : V) : u = v := by
-  have hM : LE_Interp .nil (WShape.T (n := 1) (.sort (decide (u ≠ .zero)))) (.sort u) :=
+theorem sort_inv_of_adequacy
+    {k : Nat} (adequacy : LR.AdequacyAt Γ (k + 1))
+    (d : IsDefEqStrong Γ (SExpr.sort u) (SExpr.sort v) V) : u = v := by
+  have hM : LE_Interp .nil
+      (WShape.T (n := k + 1) (.sort (decide (u ≠ .zero)))) (.sort u) :=
     .sort TShape.sort_eqv.1
   have ⟨n, mU, mV, h1, h2, h3, hA, h5⟩ := (LE_Interp.sound d .nil).2 hM |>.out
   have h2' := WShape.lift_sort ▸ (TShape.LE.lift_l h1).1 h2; dsimp only at h2'
   cases WShape.sort_le.1 h2'
-  cases show mV = (.sort true : WShape 1).lift n by
+  cases show mV = (.sort true : WShape (k + 1)).lift n by
     let _+1 := n
     simp only [WShape.HasType, WShape.sort] at h5
     ext1; generalize mV.val = mv at h5
     let .sort := Shape.HasType.unfold_iff.1 h5; rfl
-  have h1' : (1 : Nat) ≤ n := h1
-  have := (LR.adequacy d hM (hA.unlift h1') .sort).2 .id
+  have h1' : k + 1 ≤ n := h1
+  have := (adequacy d hM (hA.unlift h1') .sort).2 .id
   have ⟨w, h1, h2⟩ := (LR _).sort_iff.1 (subst_id ▸ subst_id ▸ subst_id ▸ this)
   cases WHNF.sort.whRedS h1; cases WHNF.sort.whRedS h2; rfl
+
+/-- Package the stratified inversion interface from positive-level adequacy
+once contextual raw type uniqueness is available.
+
+The raw uniqueness argument is used only to collapse the path-valued Pi
+observation and to align the universe indices on the shallower stratified
+domain/codomain typings.  This remains a useful successor-stage adapter; the
+level-zero bootstrap is instead solved non-circularly by
+`JointStratifiedInversion.of_adequacy` above. -/
+theorem JointStratifiedInversion.of_adequacy_and_typeUniq
+    (adequacy : LR.ContextualAdequacyAt 1)
+    (uniq : LogRel.ContextualRawTypeUniq) :
+    JointStratifiedInversion where
+  sortInv hΓ h := sort_inv_of_adequacy (k := 0) (adequacy hΓ) h
+  forallEInv := by
+    intro Γ A B A' B' V V' s n n' hΓ h hL hR
+    obtain ⟨uL, vL, hAL, hBL⟩ := hL.forallE_inv
+    obtain ⟨uR, vR, hAR, hBR⟩ := hR.forallE_inv
+    obtain ⟨u, v, hAA, hBB⟩ :=
+      forallE_inv_of_adequacy_collapsed (n := 0)
+        (adequacy hΓ) uniq hΓ h
+    have levelEq {Δ : List SExpr} (hΔ : Ctx.WF Δ)
+        {X : SExpr} {l₁ l₂ : SLevel}
+        (hx₁ : IsDefEq Δ X X (.sort l₁))
+        (hx₂ : IsDefEq Δ X X (.sort l₂)) : l₁ = l₂ := by
+      obtain ⟨_, hs⟩ := uniq hΔ hx₁ hx₂
+      exact sort_inv_of_adequacy (k := 0) (adequacy hΔ) (hs.strong hΔ)
+    have huL : uL = u := levelEq hΓ hAL.hasType hAA.hasType.1
+    cases huL
+    have hΓA : Ctx.WF (A :: _) := ⟨hΓ, ⟨_, hAA.hasType.1⟩⟩
+    have hvL : vL = v := levelEq hΓA hBL.hasType hBB.hasType.1
+    cases hvL
+    have hΓA' : Ctx.WF (A' :: _) := ⟨hΓ, ⟨_, hAA.hasType.2⟩⟩
+    have hBB' : IsDefEq (A' :: _) B' B' (.sort vL) :=
+      hAA.defeqDF_l hBB.hasType.2
+    have hvR : vR = vL := levelEq hΓA' hBR.hasType hBB'
+    cases hvR
+    exact ⟨⟨uL, hAA, hAL⟩, vL, hBB, hBL, hBR⟩
+
+theorem sort_inv (hΓ : Ctx.WF Γ)
+    (d : IsDefEqStrong Γ (SExpr.sort u) (SExpr.sort v) V) : u = v :=
+  sort_inv_of_adequacy (k := 0) (LR.adequacyAt Γ hΓ 1) d
+
+/-- Experimental end-to-end sort injectivity for `VExpr`, assuming the rewrite-rule
+infrastructure packaged by `SExpr.Params`. -/
+theorem _root_.Lean4Lean.VEnv.IsDefEqU.sort_invS
+    [Params.Semantic]
+    (hΓ : OnCtx Γ (Params.env.IsType Params.univs))
+    (h : Params.env.IsDefEqU Params.univs Γ (.sort u) (.sort v)) : u ≈ v := by
+  obtain ⟨A, h⟩ := h
+  have hΓwf := (VEnv.CtxStrong.strong Params.henv hΓ).levelWF
+  have hu : u.WF Params.univs := (h.levelWF hΓwf).1
+  have hv : v.WF Params.univs := (h.levelWF hΓwf).2.1
+  have huv := SExpr.sort_inv (Ctx.WF.mkS hΓ)
+    ((h.strong Params.henv hΓ).mkS)
+  apply VLevel.equiv_def'.2
+  rw [← SLevel.mk_val hu, ← SLevel.mk_val hv, huv]
diff --git a/Lean4Lean/Experimental/StepIndexed.lean b/Lean4Lean/Experimental/StepIndexed.lean
index 7b32fcac..e83c4f02 100644
--- a/Lean4Lean/Experimental/StepIndexed.lean
+++ b/Lean4Lean/Experimental/StepIndexed.lean
@@ -8,7 +8,7 @@ variable [Params]
 structure Classifier' where
   level : SLevel
   HasTy' (e : SExpr) : Prop
-def Classifier (_Γ : List SExpr) (_A : SExpr) := Classifier'
+@[implicit_reducible] def Classifier (_Γ : List SExpr) (_A : SExpr) := Classifier'
 
 def Classifier.HasTy (C : Classifier Γ A) (e : SExpr) : Prop := Γ ⊢ e : A ∧ C.HasTy' e
 
diff --git a/Lean4Lean/Experimental/Stratified.lean b/Lean4Lean/Experimental/Stratified.lean
index 24c19393..71fa6bc9 100644
--- a/Lean4Lean/Experimental/Stratified.lean
+++ b/Lean4Lean/Experimental/Stratified.lean
@@ -1,332 +1,11 @@
 import Lean4Lean.Theory.Typing.Lemmas
 import Lean4Lean.Theory.Typing.Strong
 
-namespace Lean4Lean
-namespace VEnv
+/-! # Parked stratification prototype
 
-open Lean4Lean VExpr
-
-def DefInv (env : VEnv) (U : Nat) (Γ : List VExpr) : VExpr → VExpr → Prop
-  | .forallE A B, .forallE A' B' =>
-    ∃ u v, env.IsDefEq U Γ A A' (.sort u) ∧ env.IsDefEq U (A::Γ) B B' (.sort v)
-  | .forallE .., .sort .. | .sort .., .forallE .. => False
-  | .sort u, .sort v => u ≈ v
-  | _, _ => True
-
-variable! (henv : Ordered env) in
-nonrec theorem DefInv.symm (h : DefInv env U Γ e1 e2) : DefInv env U Γ e2 e1 := by
-  cases e1 <;> cases e2 <;> try trivial
-  · exact h.symm
-  · let ⟨u, v, h1, h2⟩ := h; exact ⟨u, v, h1.symm, h1.defeqDF_l henv h2.symm⟩
-
-section
-set_option hygiene false
-local notation:65 Γ " ⊢ " e " : " A:30 => HasType1 Γ e A
-local notation:65 Γ " ⊢ " e1 " ≡ " e2 " : " A:30 => IsDefEq1 Γ e1 e2 A
-
-variable (env : VEnv) (uvars : Nat)
-
-variable (IsDefEq1 : List VExpr → VExpr → VExpr → VExpr → Prop) in
-inductive HasType1 : List VExpr → VExpr → VExpr → Prop where
-  | bvar : Lookup Γ i A → Γ ⊢ .bvar i : A
-  | const :
-    env.constants c = some ci →
-    (∀ l ∈ ls, l.WF uvars) →
-    ls.length = ci.uvars →
-    Γ ⊢ .const c ls : ci.type.instL ls
-  | sort : l.WF uvars → Γ ⊢ .sort l : .sort (.succ l)
-  | app : Γ ⊢ f : .forallE A B → Γ ⊢ a : A → Γ ⊢ .app f a : B.inst a
-  | lam : Γ ⊢ A : .sort u → A::Γ ⊢ body : B → Γ ⊢ .lam A body : .forallE A B
-  | forallE : Γ ⊢ A : .sort u → A::Γ ⊢ body : .sort v → Γ ⊢ .forallE A body : .sort (.imax u v)
-  | defeq : Γ ⊢ A ≡ B : .sort u → Γ ⊢ e : A → Γ ⊢ e : B
-
-variable
-  (HasType1 : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → VExpr → Prop) in
-inductive IsDefEq1 : List VExpr → VExpr → VExpr → VExpr → Prop where
-  | refl : Γ ⊢ e : A → Γ ⊢ e ≡ e : A
-  | symm : Γ ⊢ e ≡ e' : A → Γ ⊢ e' ≡ e : A
-  | trans : Γ ⊢ e₁ ≡ e₂ : A → Γ ⊢ e₂ ≡ e₃ : A → Γ ⊢ e₁ ≡ e₃ : A
-  | constDF :
-    env.constants c = some ci →
-    (∀ l ∈ ls, l.WF uvars) →
-    (∀ l ∈ ls', l.WF uvars) →
-    ls.length = ci.uvars →
-    List.Forall₂ (· ≈ ·) ls ls' →
-    Γ ⊢ .const c ls ≡ .const c ls' : ci.type.instL ls
-  | sortDF : l.WF uvars → l'.WF uvars → l ≈ l' → Γ ⊢ .sort l ≡ .sort l' : .sort l.succ
-  | appDF :
-    Γ ⊢ f ≡ f' : .forallE A B → Γ ⊢ a ≡ a' : A → Γ ⊢ .app f a ≡ .app f' a' : B.inst a
-  | lamDF : Γ ⊢ A ≡ A' : .sort u → A::Γ ⊢ b ≡ b' : B → Γ ⊢ .lam A b ≡ .lam A' b' : .forallE A B
-  | forallEDF :
-    Γ ⊢ A ≡ A' : .sort u → A::Γ ⊢ B ≡ B' : .sort v →
-    Γ ⊢ .forallE A B ≡ .forallE A' B' : .sort (.imax u v)
-  | defeqDF : defEq Γ A B (.sort u) → Γ ⊢ e₁ ≡ e₂ : A → Γ ⊢ e₁ ≡ e₂ : B
-  | beta : A::Γ ⊢ e : B → Γ ⊢ e' : A → Γ ⊢ .app (.lam A e) e' ≡ e.inst e' : B.inst e'
-  | eta : Γ ⊢ e : .forallE A B → Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B
-  | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ h' : p
-  | extra :
-    env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
-    Γ ⊢ df.lhs.instL ls ≡ df.rhs.instL ls : df.type.instL ls
-
-end
-
-variable! (henv : Ordered env) (hΓ : OnCtx Γ (env.IsType U)) in
-theorem IsDefEq.induction1
-    (defEq : List VExpr → VExpr → VExpr → VExpr → Prop)
-    (hasType : List VExpr → VExpr → VExpr → Prop)
-    (hty : ∀ {Γ e A}, HasType1 env U defEq Γ e A → hasType Γ e A)
-    (hdf : ∀ {Γ e1 e2 A}, IsDefEq1 env U hasType defEq Γ e1 e2 A → defEq Γ e1 e2 A)
-    (H : env.IsDefEq U Γ e1 e2 A) :
-    HasType1 env U defEq Γ e1 A ∧
-    HasType1 env U defEq Γ e2 A ∧
-    IsDefEq1 env U hasType defEq Γ e1 e2 A := by
-  have H' := H.strong henv hΓ; clear hΓ H
-  induction H' with
-  | bvar h => exact ⟨.bvar h, .bvar h, .refl (hty (.bvar h))⟩
-  | symm _ ih => exact ⟨ih.2.1, ih.1, .symm ih.2.2⟩
-  | trans _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2.1, .trans ih1.2.2 ih2.2.2⟩
-  | @constDF _ _ ls₁ ls₂ u _ h1 h2 h3 h4 h5 =>
-    exact ⟨.const h1 h2 h4,
-      .defeq (u := u.inst ls₁) sorry <| .const h1 h3 (h5.length_eq.symm.trans h4),
-      .constDF h1 h2 h3 h4 h5⟩
-  | @sortDF l l' _ h1 h2 h3 =>
-    refine ⟨.sort h1, ?_, .sortDF h1 h2 h3⟩
-    exact .defeq (hdf <| .symm <| .sortDF (l' := l'.succ) h1 h2 (VLevel.succ_congr h3)) (.sort h2)
-  | appDF _ _ _ _ _ _ _ _ _ ihf iha ihBa =>
-    let ⟨hf, hf', ff⟩ := ihf; let ⟨ha, ha', aa⟩ := iha
-    exact ⟨.app hf ha, .defeq (hdf ihBa.2.2.symm) (.app hf' ha'), .appDF ff aa⟩
-  | lamDF _ _ _ _ _ _ _ ihA ihB _ ihb ihb' =>
-    refine ⟨.lam ihA.1 ihb.1, ?_, .lamDF ihA.2.2 ihb.2.2⟩
-    exact .defeq (hdf <| .symm <| .forallEDF ihA.2.2 ihB.2.2) <| .lam ihA.2.1 ihb'.2.1
-  | forallEDF _ _ _ _ _ ih1 ih2 ih3 =>
-    exact ⟨.forallE ih1.1 ih2.1, .forallE ih1.2.1 ih3.2.1, .forallEDF ih1.2.2 ih2.2.2⟩
-  | defeqDF _ _ _ ih1 ih2 =>
-    exact ⟨.defeq (hdf ih1.2.2) ih2.1, .defeq (hdf ih1.2.2) ih2.2.1, .defeqDF (hdf ih1.2.2) ih2.2.2⟩
-  | beta _ _ _ _ _ _ _ _ ihA _ ihe ihe' _ ihee =>
-    exact ⟨.app (.lam ihA.1 ihe.1) ihe'.1, ihee.1, .beta (hty ihe.1) (hty ihe'.1)⟩
-  | eta _ _ _ _ _ _ _ _ ihA _ _ ihe ihe' =>
-    have := HasType1.app ihe'.1 (.bvar .zero)
-    rw [instN_bvar0] at this
-    exact ⟨.lam ihA.1 this, ihe.1, .eta (hty ihe.1)⟩
-  | proofIrrel _ _ _ ih1 ih2 ih3 =>
-    exact ⟨ih2.1, ih3.1, .proofIrrel (hty ih1.1) (hty ih2.1) (hty ih3.1)⟩
-  | extra h1 h2 h3 _ _ _ _ _ _ _ _ _ ihl' ihr' =>
-    exact ⟨ihl'.1, ihr'.1, .extra h1 h2 h3⟩
-
-variable! {env : VEnv}
-  {defEq : List VExpr → VExpr → VExpr → VExpr → Prop}
-  (IH : ∀ {Γ e1 e2 A}, defEq Γ e1 e2 A → env.IsDefEq U Γ e1 e2 A) in
-theorem HasType1.induction (H : env.HasType1 U defEq Γ e A) : env.HasType U Γ e A := by
-  induction H with
-  | bvar h => exact .bvar h
-  | const h1 h2 h3 => exact .const h1 h2 h3
-  | sort h => exact .sort h
-  | app _ _ ih1 ih2 => exact .app ih1 ih2
-  | lam _ _ ih1 ih2 => exact .lam ih1 ih2
-  | forallE _ _ ih1 ih2 => exact .forallE ih1 ih2
-  | defeq h1 _ ih => exact (IH h1).defeq ih
-
-variable! {env : VEnv}
-  {hasType : List VExpr → VExpr → VExpr → Prop}
-  {defEq : List VExpr → VExpr → VExpr → VExpr → Prop}
-  (hty : ∀ {Γ e A}, hasType Γ e A → env.HasType U Γ e A)
-  (hdf : ∀ {Γ e1 e2 A}, defEq Γ e1 e2 A → env.IsDefEq U Γ e1 e2 A) in
-theorem IsDefEq1.induction
-    (H : env.IsDefEq1 U hasType defEq Γ e1 e2 A) : env.IsDefEq U Γ e1 e2 A := by
-  induction H with
-  | refl h => exact hty h
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ih1.trans ih2
-  | constDF h1 h2 h3 h4 h5 => exact .constDF h1 h2 h3 h4 h5
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF h1 _ ih => exact .defeqDF (hdf h1) ih
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
-
-/-
-variable!
-  {U : Nat}
-  (hasType : List VExpr → VExpr → VExpr → Prop)
-  (hasType' : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → VExpr → Prop)
-  (refl : ∀ {Γ e A}, hasType Γ e A → hasType' Γ e A)
-  (sort : ∀ {Γ l l'}, l.WF U → l'.WF U → l ≈ l' →
-    hasType' Γ (.sort l') (.sort l.succ))
-  (app : ∀ {Γ f a A B},
-    hasType' Γ f (.forallE A B) → hasType' Γ a A → hasType' Γ (.app f a) (B.inst a))
-in
-protected theorem IsDefEq1.hasType_ind
-    (H : IsDefEq1 env U hasType defEq Γ e1 e2 A) :
-    hasType' Γ e1 A ∧ hasType' Γ e2 A := by
-  induction H with
-  | refl h => exact ⟨refl h, refl h⟩
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2⟩
-  | sortDF h1 h2 h3 => exact ⟨sort h1 h1 rfl, sort h1 h2 h3⟩
-  | appDF _ _ ih1 ih2 =>
-    exact ⟨app ih1.1 ih2.1, app _ _⟩
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF h1 _ ih => exact .defeqDF (hdf h1) ih
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
-
-variable!
-  (hasType : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → VExpr → Prop) in
-inductive IsDefEqU1 : List VExpr → VExpr → VExpr → VLevel → Prop
-  | refl : hasType Γ A (.sort u) → IsDefEqU1 Γ A A u
-
-variable! (henv : Ordered env)
-  {hasType : List VExpr → VExpr → VExpr → Prop}
-  {defEq : List VExpr → VExpr → VExpr → VExpr → Prop}
-  (refl : ∀ {Γ e A}, hasType Γ e A → defEq' Γ e e A)
-  (hdf : ∀ {Γ e1 e2 A}, defEq Γ e1 e2 A → env.IsDefEq U Γ e1 e2 A) in
-theorem IsDefEq1.unique_typing1
-    (H : env.IsDefEq1 U hasType defEq Γ e1 e2 A) :
-    hasType Γ e1 A ∧ hasType Γ e2 A := by
-  induction H with
-  | refl h => exact hty h
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ih1.trans ih2
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF h1 _ ih => exact .defeqDF (hdf h1) ih
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
-
-variable! (henv : Ordered env) in
-theorem HasType1.unique_typing'
-    (H1 : env.HasType1 U (IsDefEq1 env U hasType defEq) Γ e A1)
-    (H2 : env.HasType1 U (IsDefEq1 env U hasType defEq) Γ e A2) :
-    ∃ u, env.IsDefEq1 U hasType defEq Γ A1 A2 (.sort u) := by
-  generalize eq1 : e = e' at H2
-  induction H1 generalizing e' A2 with subst eq1
-  | defeq h1 _ ih =>
-    let ⟨_, ih⟩ := ih _ rfl H2
-    exact ⟨_, h1.trans _⟩
-    done
-  | _ => ?_
-  <;> cases H2
-
-  case bvar.bvar _ =>
-    done
-  case const.const _ _ _ =>
-    done
-  case sort.sort _ =>
-    done
-  case app.app _ _ _ _ =>
-    done
-  case lam.lam _ _ _ _ =>
-    done
-  case forallE.forallE _ _ _ _ =>
-    done
-  case defeq.defeq _ _ _ =>
-    done
-  _
-  -- | bvar h =>
-  --   refine .bvar h.instL
-  -- | @const _ _ ls' _ h1 h2 h3 =>
-  --   simp [instL, instL_instL]
-  --   exact .const h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
-  -- | sort _ _ h3 =>
-  --   exact .sortDF (VLevel.WF.inst hls) (VLevel.WF.inst hls) (VLevel.inst_congr_l h3)
-  -- | app _ _ ih1 ih2 => exact instL_instN ▸ .appDF ih1 ih2
-  -- | lam _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  -- | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  -- | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  -- | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2
-  -- | eta _ ih => simpa [instL] using .eta ih
-  -- | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  -- | extra h1 h2 h3 =>
-  --   simp [instL, instL_instL]
-  --   exact .extra h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
--/
-
-/-
-variable! (henv : Ordered env) in
-theorem IsDefEq.unique_typing'
-    (H1 : env.IsDefEq U Γ e1 e2 A1) (H2 : env.IsDefEq U Γ e1 e2 A2) :
-    ∃ u, env.IsDefEq U Γ A1 A2 (.sort u) := by
-  generalize eq1 : e1 = e1', eq2 : e2 = e2' at H2
-  induction H1 generalizing A2 with
-  | bvar h =>
-
-    refine .bvar h.instL
-  | @const _ _ ls' _ h1 h2 h3 =>
-    simp [instL, instL_instL]
-    exact .const h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sortDF _ _ h3 =>
-    exact .sortDF (VLevel.WF.inst hls) (VLevel.WF.inst hls) (VLevel.inst_congr_l h3)
-  | appDF _ _ ih1 ih2 => exact instL_instN ▸ .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2
-  | eta _ ih => simpa [instL] using .eta ih
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 h3 =>
-    simp [instL, instL_instL]
-    exact .extra h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
--/
-
-
-/- depends on church-rosser
-variable! {env : VEnv} (henv : env.Ordered) in
-theorem IsDefEq.weakN_inv (W : Ctx.LiftN n k Γ Γ')
-    (H : env.IsDefEq U Γ' (e1.liftN n k) (e2.liftN n k) (A.liftN n k)) :
-    env.IsDefEq U Γ e1 e2 A := by
-  generalize eq1 : e1.liftN n k = e1', eq2 : e2.liftN n k = e2', eqA : A.liftN n k = A' at H
-  induction H generalizing k e1 e2 A with
-  | bvar h =>
-    cases eqA; cases e1 <;> cases eq1; cases e2 <;> injection eq2
-    cases liftVar_inj.1 ‹_›; exact .bvar (h.weakN_inv W)
-  | @const c ci ls Γ h1 h2 h3 =>
-    cases e1 <;> cases eq1; cases e2 <;> cases eq2
-    rw [ClosedN.liftN_eq_rev (eqA ▸ (henv.closedC h1).instL) (Nat.zero_le _)] at eqA
-    exact eqA ▸ .const h1 h2 h3
-  | symm _ ih => exact .symm (ih W eq2 eq1 eqA)
-  | trans _ _ ih1 ih2 => sorry
-  -- | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  -- | appDF _ _ ih1 ih2 => exact liftN_inst_hi .. ▸ .appDF (ih1 W) (ih2 W)
-  -- | lamDF _ _ ih1 ih2 => exact .lamDF (ih1 W) (ih2 W.succ)
-  -- | forallEDF _ _ ih1 ih2 => exact .forallEDF (ih1 W) (ih2 W.succ)
-  -- | defeqDF _ _ ih1 ih2 => exact .defeqDF (ih1 W) (ih2 W)
-  -- | beta _ _ ih1 ih2 =>
-  --   exact liftN_inst_hi .. ▸ liftN_instN_hi .. ▸ .beta (ih1 W.succ) (ih2 W)
-  -- | eta _ ih =>
-  --   have := IsDefEq.eta (ih W)
-  --   simp [liftN]; rwa [← lift_liftN']
-  -- | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
-  -- | extra h1 h2 h3 =>
-  --   have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
-  --   rw [
-  --     hA1.instL.liftN_eq (Nat.zero_le _),
-  --     hA2.instL.liftN_eq (Nat.zero_le _),
-  --     hA3.instL.liftN_eq (Nat.zero_le _)]
-  --   exact .extra h1 h2 h3
-  | _ => sorry
-
-variable! {env : VEnv} (henv : env.Ordered) in
-theorem HasType.weakN_inv (W : Ctx.LiftN n k Γ Γ')
-    (H : env.HasType U Γ' (e.liftN n k) (A.liftN n k)) :
-    env.HasType U Γ e A := IsDefEq.weakN_inv henv W H
-
-variable! {env : VEnv} (henv : env.Ordered) in
-theorem IsType.weakN_inv (W : Ctx.LiftN n k Γ Γ') (H : env.IsType U Γ' (A.liftN n k)) :
-    env.IsType U Γ A := let ⟨_, h⟩ := H; ⟨_, h.weakN_inv henv W⟩
+This pre-L4L-15 prototype targeted the old, non-mutual `IsDefEq` judgment
+and was never imported by a supported root.  It is intentionally parked as
+an import-compatible stub; the maintained stratification development lives
+in `Theory.Typing.Strong`, and the semantic route used by L4L-16 lives in
+`Experimental.SExpr` and `Experimental.ShapeLogRelAdequacy`.
 -/
diff --git a/Lean4Lean/Experimental/StratifiedUntyped.lean b/Lean4Lean/Experimental/StratifiedUntyped.lean
index a3a9218a..4acdd427 100644
--- a/Lean4Lean/Experimental/StratifiedUntyped.lean
+++ b/Lean4Lean/Experimental/StratifiedUntyped.lean
@@ -1,317 +1,10 @@
 import Lean4Lean.Theory.Typing.Lemmas
 import Lean4Lean.Theory.Typing.Strong
 
-namespace Lean4Lean
-namespace VEnv
+/-! # Parked untyped-stratification prototype
 
-open Lean4Lean VExpr
-
-section
-set_option hygiene false
-local notation:65 Γ " ⊢ " e " : " A:30 => HasTypeU1 Γ e A
-local notation:65 Γ " ⊢ " e1 " ≡ " e2:30 => IsDefEqU1 Γ e1 e2
-
-variable (env : VEnv) (uvars : Nat)
-
-variable (IsDefEqU1 : List VExpr → VExpr → VExpr → Prop) in
-inductive HasTypeU1 : List VExpr → VExpr → VExpr → Prop where
-  | bvar : Lookup Γ i A → Γ ⊢ .bvar i : A
-  | const :
-    env.constants c = some ci →
-    (∀ l ∈ ls, l.WF uvars) →
-    ls.length = ci.uvars →
-    Γ ⊢ .const c ls : ci.type.instL ls
-  | sort : l.WF uvars → Γ ⊢ .sort l : .sort (.succ l)
-  | app : Γ ⊢ f : .forallE A B → Γ ⊢ a : A → Γ ⊢ .app f a : B.inst a
-  | lam : Γ ⊢ A : .sort u → A::Γ ⊢ body : B → Γ ⊢ .lam A body : .forallE A B
-  | forallE : Γ ⊢ A : .sort u → A::Γ ⊢ body : .sort v → Γ ⊢ .forallE A body : .sort (.imax u v)
-  | defeq : Γ ⊢ A ≡ B → Γ ⊢ e : A → Γ ⊢ e : B
-
-variable
-  (HasTypeU1 : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → Prop) in
-inductive IsDefEqU1 : List VExpr → VExpr → VExpr → Prop where
-  | refl : Γ ⊢ e ≡ e
-  | symm : Γ ⊢ e ≡ e' → Γ ⊢ e' ≡ e
-  | trans : Γ ⊢ e₁ ≡ e₂ → Γ ⊢ e₂ ≡ e₃ → Γ ⊢ e₁ ≡ e₃
-  | constDF : List.Forall₂ (· ≈ ·) ls ls' → Γ ⊢ .const c ls ≡ .const c ls'
-  | sortDF : l ≈ l' → Γ ⊢ .sort l ≡ .sort l'
-  | appDF :
-    Γ ⊢ f ≡ f' → Γ ⊢ a ≡ a' → Γ ⊢ .app f a ≡ .app f' a'
-  | lamDF : Γ ⊢ A ≡ A' → A::Γ ⊢ b ≡ b' → Γ ⊢ .lam A b ≡ .lam A' b'
-  | forallEDF :
-    Γ ⊢ A ≡ A' → A::Γ ⊢ B ≡ B' →
-    Γ ⊢ .forallE A B ≡ .forallE A' B'
-  | beta : A::Γ ⊢ e : B → Γ ⊢ e' : A → Γ ⊢ .app (.lam A e) e' ≡ e.inst e'
-  | eta : Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e
-  | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ h'
-  | extra :
-    env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
-    Γ ⊢ df.lhs.instL ls ≡ df.rhs.instL ls
-
-end
-
-variable! (henv : Ordered env) (hΓ : OnCtx Γ (env.IsType U)) in
-theorem IsDefEq.inductionU1
-    (defEq : List VExpr → VExpr → VExpr → Prop)
-    (hasType : List VExpr → VExpr → VExpr → Prop)
-    (hty : ∀ {Γ e A}, HasTypeU1 env U defEq Γ e A → hasType Γ e A)
-    (hdf : ∀ {Γ e1 e2 A1 A2},
-      HasTypeU1 env U defEq Γ e1 A1 → HasTypeU1 env U defEq Γ e2 A2 →
-      IsDefEqU1 env U hasType Γ e1 e2 → defEq Γ e1 e2)
-    (H : env.IsDefEq U Γ e1 e2 A) :
-    HasTypeU1 env U defEq Γ e1 A ∧
-    HasTypeU1 env U defEq Γ e2 A ∧
-    IsDefEqU1 env U hasType Γ e1 e2 := by
-  have H' := H.strong henv hΓ; clear hΓ H
-  induction H' with
-  | bvar h => exact ⟨.bvar h, .bvar h, .refl⟩
-  | symm _ ih => exact ⟨ih.2.1, ih.1, .symm ih.2.2⟩
-  | trans _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2.1, .trans ih1.2.2 ih2.2.2⟩
-  | @constDF _ _ ls₁ ls₂ _ _ h1 h2 h3 h4 h5 =>
-    exact ⟨.const h1 h2 h4, .defeq sorry <| .const h1 h3 (h5.length_eq.symm.trans h4), .constDF h5⟩
-  | @sortDF l l' _ h1 h2 h3 =>
-    refine ⟨.sort h1, ?_, .sortDF h3⟩
-    exact .defeq (hdf (.sort (l := l'.succ) h2) (.sort (l := l.succ) h1)
-      (.sortDF <| VLevel.succ_congr h3.symm)) (.sort h2)
-  | appDF _ _ _ _ _ _ _ _ _ ihf iha ihBa =>
-    let ⟨hf, hf', ff⟩ := ihf; let ⟨ha, ha', aa⟩ := iha
-    exact ⟨.app hf ha, .defeq (hdf ihBa.2.1 ihBa.1 (.symm ihBa.2.2)) (.app hf' ha'), .appDF ff aa⟩
-  | lamDF _ _ _ _ _ _ _ ihA ihB ihB' ihb ihb' =>
-    refine ⟨.lam ihA.1 ihb.1, .defeq ?_ <| .lam ihA.2.1 ihb'.2.1, .lamDF ihA.2.2 ihb.2.2⟩
-    exact hdf (.forallE ihA.2.1 ihB'.1) (.forallE ihA.1 ihB.1) <|
-      .symm <| .forallEDF ihA.2.2 ihB.2.2
-  | forallEDF _ _ _ _ _ ih1 ih2 ih3 =>
-    exact ⟨.forallE ih1.1 ih2.1, .forallE ih1.2.1 ih3.2.1, .forallEDF ih1.2.2 ih2.2.2⟩
-  | defeqDF _ _ _ ih1 ih2 =>
-    have h := hdf ih1.1 ih1.2.1 ih1.2.2; exact ⟨.defeq h ih2.1, .defeq h ih2.2.1, ih2.2.2⟩
-  | beta _ _ _ _ _ _ _ _ ihA _ ihe ihe' _ ihee =>
-    exact ⟨.app (.lam ihA.1 ihe.1) ihe'.1, ihee.1, .beta (hty ihe.1) (hty ihe'.1)⟩
-  | eta _ _ _ _ _ _ _ _ ihA _ _ ihe ihe' =>
-    have := HasTypeU1.app ihe'.1 (.bvar .zero)
-    rw [instN_bvar0] at this
-    exact ⟨.lam ihA.1 this, ihe.1, .eta⟩
-  | proofIrrel _ _ _ ih1 ih2 ih3 =>
-    exact ⟨ih2.1, ih3.1, .proofIrrel (hty ih1.1) (hty ih2.1) (hty ih3.1)⟩
-  | extra h1 h2 h3 _ _ _ _ _ _ _ _ _ ihl' ihr' =>
-    exact ⟨ihl'.1, ihr'.1, .extra h1 h2 h3⟩
-
-variable! (henv : Ordered env) (hΓ : OnCtx Γ (env.IsType U))
-  {defEq : List VExpr → VExpr → VExpr → Prop}
-  (IH : ∀ {Γ e1 e2 A}, env.HasType U Γ e1 A → defEq Γ e1 e2 → env.IsDefEq U Γ e1 e2 A) in
-theorem HasTypeU1.induction (H : env.HasTypeU1 U defEq Γ e A) : env.HasType U Γ e A := by
-  induction H with
-  | bvar h => exact .bvar h
-  | const h1 h2 h3 => exact .const h1 h2 h3
-  | sort h => exact .sort h
-  | app _ _ ih1 ih2 => exact .app (ih1 hΓ) (ih2 hΓ)
-  | lam _ _ ih1 ih2 => exact .lam (ih1 hΓ) (ih2 ⟨hΓ, _, ih1 hΓ⟩)
-  | forallE _ _ ih1 ih2 => exact .forallE (ih1 hΓ) (ih2 ⟨hΓ, _, ih1 hΓ⟩)
-  | defeq h1 _ ih =>
-    let ⟨_, h⟩ := (ih hΓ).isType henv hΓ
-    exact (IH h h1).defeq (ih hΓ)
-
-/-
-variable (henv : Ordered env)
-  {hasType : List VExpr → VExpr → VExpr → Prop}
-  {defEq : List VExpr → VExpr → VExpr → VExpr → Prop}
-  (hty : ∀ {Γ e A}, hasType Γ e A → env.HasType U Γ e A)
-  (hdf : ∀ {Γ e1 e2 A}, defEq Γ e1 e2 A → env.IsDefEq U Γ e1 e2 A) in
-theorem IsDefEqU1.induction
-    (H1 : env.HasType U Γ e1 A) (H2 : env.HasType U Γ e2 A)
-    (H : env.IsDefEqU1 U hasType Γ e1 e2) : env.IsDefEq U Γ e1 e2 A := by
-  induction H with
-  | refl => exact H1
-  | symm _ ih => exact (ih H2 H1).symm
-  | trans _ _ ih1 ih2 => exact ih1.trans ih2
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
--/
-
-/-
-variable
-  {U : Nat}
-  (hasType : List VExpr → VExpr → VExpr → Prop)
-  (hasType' : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → VExpr → Prop)
-  (refl : ∀ {Γ e A}, hasType Γ e A → hasType' Γ e A)
-  (sort : ∀ {Γ l l'}, l.WF U → l'.WF U → l ≈ l' →
-    hasType' Γ (.sort l') (.sort l.succ))
-  (app : ∀ {Γ f a A B},
-    hasType' Γ f (.forallE A B) → hasType' Γ a A → hasType' Γ (.app f a) (B.inst a))
-in
-protected theorem IsDefEqU1.hasType_ind
-    (H : IsDefEqU1 env U hasType defEq Γ e1 e2 A) :
-    hasType' Γ e1 A ∧ hasType' Γ e2 A := by
-  induction H with
-  | refl h => exact ⟨refl h, refl h⟩
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2⟩
-  | sortDF h1 h2 h3 => exact ⟨sort h1 h1 rfl, sort h1 h2 h3⟩
-  | appDF _ _ ih1 ih2 =>
-    exact ⟨app ih1.1 ih2.1, app _ _⟩
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF h1 _ ih => exact .defeqDF (hdf h1) ih
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
-
-variable
-  (hasType : List VExpr → VExpr → VExpr → Prop)
-  (defEq : List VExpr → VExpr → VExpr → VExpr → Prop) in
-inductive IsDefEqU1 : List VExpr → VExpr → VExpr → VLevel → Prop
-  | refl : hasType Γ A (.sort u) → IsDefEqU1 Γ A A u
-
-variable (henv : Ordered env)
-  {hasType : List VExpr → VExpr → VExpr → Prop}
-  {defEq : List VExpr → VExpr → VExpr → VExpr → Prop}
-  (refl : ∀ {Γ e A}, hasType Γ e A → defEq' Γ e e A)
-  (hdf : ∀ {Γ e1 e2 A}, defEq Γ e1 e2 A → env.IsDefEq U Γ e1 e2 A) in
-theorem IsDefEqU1.unique_typing1
-    (H : env.IsDefEqU1 U hasType defEq Γ e1 e2 A) :
-    hasType Γ e1 A ∧ hasType Γ e2 A := by
-  induction H with
-  | refl h => exact hty h
-  | symm _ ih => exact ih.symm
-  | trans _ _ ih1 ih2 => exact ih1.trans ih2
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF h1 _ ih => exact .defeqDF (hdf h1) ih
-  | beta h1 h2 => exact .beta (hty h1) (hty h2)
-  | eta h => exact .eta (hty h)
-  | proofIrrel h1 h2 h3 => exact .proofIrrel (hty h1) (hty h2) (hty h3)
-  | extra h1 h2 h3 => exact .extra h1 h2 h3
-
-variable (henv : Ordered env) in
-theorem HasType1.unique_typing'
-    (H1 : env.HasType1 U (IsDefEqU1 env U hasType defEq) Γ e A1)
-    (H2 : env.HasType1 U (IsDefEqU1 env U hasType defEq) Γ e A2) :
-    ∃ u, env.IsDefEqU1 U hasType defEq Γ A1 A2 (.sort u) := by
-  generalize eq1 : e = e' at H2
-  induction H1 generalizing e' A2 with subst eq1
-  | defeq h1 _ ih =>
-    let ⟨_, ih⟩ := ih _ rfl H2
-    exact ⟨_, h1.trans _⟩
-    done
-  | _ => ?_
-  <;> cases H2
-
-  case bvar.bvar _ =>
-    done
-  case const.const _ _ _ =>
-    done
-  case sort.sort _ =>
-    done
-  case app.app _ _ _ _ =>
-    done
-  case lam.lam _ _ _ _ =>
-    done
-  case forallE.forallE _ _ _ _ =>
-    done
-  case defeq.defeq _ _ _ =>
-    done
-  _
-  -- | bvar h =>
-  --   refine .bvar h.instL
-  -- | @const _ _ ls' _ h1 h2 h3 =>
-  --   simp [instL, instL_instL]
-  --   exact .const h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
-  -- | sort _ _ h3 =>
-  --   exact .sortDF (VLevel.WF.inst hls) (VLevel.WF.inst hls) (VLevel.inst_congr_l h3)
-  -- | app _ _ ih1 ih2 => exact instL_instN ▸ .appDF ih1 ih2
-  -- | lam _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  -- | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  -- | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  -- | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2
-  -- | eta _ ih => simpa [instL] using .eta ih
-  -- | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  -- | extra h1 h2 h3 =>
-  --   simp [instL, instL_instL]
-  --   exact .extra h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
--/
-
-/-
-variable (henv : Ordered env) in
-theorem IsDefEq.unique_typing'
-    (H1 : env.IsDefEq U Γ e1 e2 A1) (H2 : env.IsDefEq U Γ e1 e2 A2) :
-    ∃ u, env.IsDefEq U Γ A1 A2 (.sort u) := by
-  generalize eq1 : e1 = e1', eq2 : e2 = e2' at H2
-  induction H1 generalizing A2 with
-  | bvar h =>
-
-    refine .bvar h.instL
-  | @const _ _ ls' _ h1 h2 h3 =>
-    simp [instL, instL_instL]
-    exact .const h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sortDF _ _ h3 =>
-    exact .sortDF (VLevel.WF.inst hls) (VLevel.WF.inst hls) (VLevel.inst_congr_l h3)
-  | appDF _ _ ih1 ih2 => exact instL_instN ▸ .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2
-  | eta _ ih => simpa [instL] using .eta ih
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 h3 =>
-    simp [instL, instL_instL]
-    exact .extra h1 (by simp [h2, VLevel.WF.inst hls]) (by simp [h3])
--/
-
-
-/- depends on church-rosser
-variable {env : VEnv} (henv : env.Ordered) in
-theorem IsDefEq.weakN_inv (W : Ctx.LiftN n k Γ Γ')
-    (H : env.IsDefEq U Γ' (e1.liftN n k) (e2.liftN n k) (A.liftN n k)) :
-    env.IsDefEq U Γ e1 e2 A := by
-  generalize eq1 : e1.liftN n k = e1', eq2 : e2.liftN n k = e2', eqA : A.liftN n k = A' at H
-  induction H generalizing k e1 e2 A with
-  | bvar h =>
-    cases eqA; cases e1 <;> cases eq1; cases e2 <;> injection eq2
-    cases liftVar_inj.1 ‹_›; exact .bvar (h.weakN_inv W)
-  | @const c ci ls Γ h1 h2 h3 =>
-    cases e1 <;> cases eq1; cases e2 <;> cases eq2
-    rw [ClosedN.liftN_eq_rev (eqA ▸ (henv.closedC h1).instL) (Nat.zero_le _)] at eqA
-    exact eqA ▸ .const h1 h2 h3
-  | symm _ ih => exact .symm (ih W eq2 eq1 eqA)
-  | trans _ _ ih1 ih2 => sorry
-  -- | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  -- | appDF _ _ ih1 ih2 => exact liftN_inst_hi .. ▸ .appDF (ih1 W) (ih2 W)
-  -- | lamDF _ _ ih1 ih2 => exact .lamDF (ih1 W) (ih2 W.succ)
-  -- | forallEDF _ _ ih1 ih2 => exact .forallEDF (ih1 W) (ih2 W.succ)
-  -- | defeqDF _ _ ih1 ih2 => exact .defeqDF (ih1 W) (ih2 W)
-  -- | beta _ _ ih1 ih2 =>
-  --   exact liftN_inst_hi .. ▸ liftN_instN_hi .. ▸ .beta (ih1 W.succ) (ih2 W)
-  -- | eta _ ih =>
-  --   have := IsDefEq.eta (ih W)
-  --   simp [liftN]; rwa [← lift_liftN']
-  -- | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
-  -- | extra h1 h2 h3 =>
-  --   have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
-  --   rw [
-  --     hA1.instL.liftN_eq (Nat.zero_le _),
-  --     hA2.instL.liftN_eq (Nat.zero_le _),
-  --     hA3.instL.liftN_eq (Nat.zero_le _)]
-  --   exact .extra h1 h2 h3
-  | _ => sorry
-
-variable {env : VEnv} (henv : env.Ordered) in
-theorem HasType.weakN_inv (W : Ctx.LiftN n k Γ Γ')
-    (H : env.HasType U Γ' (e.liftN n k) (A.liftN n k)) :
-    env.HasType U Γ e A := IsDefEq.weakN_inv henv W H
-
-variable {env : VEnv} (henv : env.Ordered) in
-theorem IsType.weakN_inv (W : Ctx.LiftN n k Γ Γ') (H : env.IsType U Γ' (A.liftN n k)) :
-    env.IsType U Γ A := let ⟨_, h⟩ := H; ⟨_, h.weakN_inv henv W⟩
+This pre-L4L-15 prototype targeted the old, non-mutual `IsDefEq` judgment
+and was never imported by a supported root.  It is intentionally parked as
+an import-compatible stub; the maintained stratification development lives
+in `Theory.Typing.Strong`.
 -/
diff --git a/Lean4Lean/Experimental/Stronger.lean b/Lean4Lean/Experimental/Stronger.lean
index 9cdf520d..a2315d97 100644
--- a/Lean4Lean/Experimental/Stronger.lean
+++ b/Lean4Lean/Experimental/Stronger.lean
@@ -1,627 +1,9 @@
 import Lean4Lean.Theory.Typing.Lemmas
 
-namespace Lean4Lean
+/-! # Parked stronger-environment prototype
 
-open Lean4Lean VExpr
-
-structure VEnv'.VConstant extends Lean4Lean.VConstant where
-  level : VLevel
-
-structure VEnv'.VDefEq extends Lean4Lean.VDefEq where
-  level : VLevel
-
-@[ext] structure VEnv' where
-  constants : Name → Option VEnv'.VConstant
-  defeqs : VEnv'.VDefEq → Prop
-
-namespace VEnv'
-
-def empty : VEnv' where
-  constants _ := none
-  defeqs _ := False
-
-instance : EmptyCollection VEnv' := ⟨.empty⟩
-
-protected def out (env : VEnv') : VEnv where
-  constants c := (env.constants c).map (·.toVConstant)
-  defeqs df := ∃ df', env.defeqs df' ∧ df = df'.toVDefEq
-
-@[simp] theorem empty_out : (∅ : VEnv').out = ∅ := by
-  simp [VEnv'.out, EmptyCollection.emptyCollection, empty, VEnv.empty]
-
-protected structure LE (env1 env2 : VEnv') : Prop where
-  constants : env1.constants n = some a → env2.constants n = some a
-  defeqs : env1.defeqs df → env2.defeqs df
-
-instance : LE VEnv' := ⟨VEnv'.LE⟩
-
-theorem LE.rfl {env : VEnv'} : env ≤ env := ⟨id, id⟩
-
-theorem LE.trans {a b c : VEnv'} (h1 : a ≤ b) (h2 : b ≤ c) : a ≤ c :=
-  ⟨h2.1 ∘ h1.1, h2.2 ∘ h1.2⟩
-
-section
-set_option hygiene false
-local notation:65 Γ " ⊢ " e " : " A:30 " : " l:30 => IsDefEqStrong Γ e e A l
-local notation:65 Γ " ⊢ " e1 " ≡ " e2 " : " A:30 " : " l:30 => IsDefEqStrong Γ e1 e2 A l
-variable (env : VEnv') (uvars : Nat)
-
-abbrev VCtx := List (VExpr × VLevel)
-
-def VCtx.out : VCtx → List VExpr := List.map Prod.fst
-
-inductive Lookup : VCtx → Nat → VExpr → VLevel → Prop where
-  | zero : Lookup ((ty, u)::Γ) 0 ty.lift u
-  | succ : Lookup Γ n ty u → Lookup ((A, v)::Γ) (n+1) ty.lift u
-
-inductive IsDefEqStrong : VCtx → VExpr → VExpr → VExpr → VLevel → Prop where
-  | bvar : Lookup Γ i A u → u.WF uvars → Γ ⊢ A : .sort u : .succ u → Γ ⊢ .bvar i : A : u
-  | symm : Γ ⊢ e ≡ e' : A : u → Γ ⊢ e' ≡ e : A : u
-  | trans : Γ ⊢ e₁ ≡ e₂ : A : u → Γ ⊢ e₂ ≡ e₃ : A : u → Γ ⊢ e₁ ≡ e₃ : A : u
-  | sortDF :
-    l.WF uvars → l'.WF uvars → l ≈ l' →
-    Γ ⊢ .sort l ≡ .sort l' : .sort (.succ l) : .succ (.succ l)
-  | constDF :
-    env.constants c = some ci →
-    (∀ l ∈ ls, l.WF uvars) →
-    (∀ l ∈ ls', l.WF uvars) →
-    ls.length = ci.uvars →
-    List.Forall₂ (· ≈ ·) ls ls' →
-    u ≈ ci.level.inst ls → u.WF uvars →
-    [] ⊢ ci.type.instL ls : .sort u : .succ u →
-    [] ⊢ ci.type.instL ls' : .sort u : .succ u →
-    Γ ⊢ ci.type.instL ls : .sort u : .succ u →
-    Γ ⊢ ci.type.instL ls' : .sort u : .succ u →
-    Γ ⊢ .const c ls ≡ .const c ls' : ci.type.instL ls : u
-  | appDF :
-    u.WF uvars → v.WF uvars →
-    Γ ⊢ A : .sort u : .succ u →
-    (A,u)::Γ ⊢ B : .sort v : .succ v →
-    Γ ⊢ f ≡ f' : .forallE A B : .imax u v →
-    Γ ⊢ a ≡ a' : A : u →
-    Γ ⊢ B.inst a ≡ B.inst a' : .sort v : .succ v →
-    Γ ⊢ .app f a ≡ .app f' a' : B.inst a : v
-  | lamDF :
-    u.WF uvars → v.WF uvars →
-    Γ ⊢ A ≡ A' : .sort u : .succ u →
-    (A, u)::Γ ⊢ B : .sort v : .succ v →
-    (A', u)::Γ ⊢ B : .sort v : .succ v →
-    (A, u)::Γ ⊢ body ≡ body' : B : v →
-    (A', u)::Γ ⊢ body ≡ body' : B : v →
-    Γ ⊢ .lam A body ≡ .lam A' body' : .forallE A B : .imax u v
-  | forallEDF :
-    u.WF uvars → v.WF uvars →
-    Γ ⊢ A ≡ A' : .sort u : .succ u →
-    (A, u)::Γ ⊢ body ≡ body' : .sort v : .succ v →
-    (A', u)::Γ ⊢ body ≡ body' : .sort v : .succ v →
-    Γ ⊢ .forallE A body ≡ .forallE A' body' : .sort (.imax u v) : .succ (.imax u v)
-  | defeqDF :
-    u.WF uvars → Γ ⊢ A ≡ B : .sort u : .succ u → Γ ⊢ e1 ≡ e2 : A : u → Γ ⊢ e1 ≡ e2 : B : u
-  | defeqL :
-    u.WF uvars → v.WF uvars → u ≈ v → Γ ⊢ e1 ≡ e2 : A : u → Γ ⊢ e1 ≡ e2 : A : v
-  | beta :
-    u.WF uvars → v.WF uvars → Γ ⊢ A : .sort u : .succ u → (A, u)::Γ ⊢ B : .sort v : .succ v →
-    (A, u)::Γ ⊢ e : B : v → Γ ⊢ e' : A : u →
-    Γ ⊢ B.inst e' : .sort v : .succ v →
-    Γ ⊢ e.inst e' : B.inst e' : v →
-    Γ ⊢ .app (.lam A e) e' ≡ e.inst e' : B.inst e' : v
-  | eta :
-    u.WF uvars → v.WF uvars →
-    Γ ⊢ A : .sort u : .succ u →
-    (A, u)::Γ ⊢ B : .sort v : .succ v →
-    (A.lift, u)::(A, u)::Γ ⊢ B.liftN 1 1 : .sort v : .succ v →
-    Γ ⊢ e : .forallE A B : .imax u v →
-    (A, u)::Γ ⊢ e.lift : .forallE A.lift (B.liftN 1 1) : .imax u v →
-    Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B : .imax u v
-  | proofIrrel :
-    Γ ⊢ p : .sort .zero : .succ .zero → Γ ⊢ h : p : .zero → Γ ⊢ h' : p : .zero →
-    Γ ⊢ h ≡ h' : p : .zero
-  | extra :
-    env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
-    u ≈ df.level.inst ls → u.WF uvars →
-    [] ⊢ df.type.instL ls : .sort u : .succ u →
-    [] ⊢ df.lhs.instL ls : df.type.instL ls : u →
-    [] ⊢ df.rhs.instL ls : df.type.instL ls : u →
-    Γ ⊢ df.lhs.instL ls : df.type.instL ls : u →
-    Γ ⊢ df.rhs.instL ls : df.type.instL ls : u →
-    Γ ⊢ df.lhs.instL ls ≡ df.rhs.instL ls : df.type.instL ls : u
-
-end
-
-def HasType (env : VEnv') (U : Nat) (Γ : VCtx) (e A : VExpr) (u : VLevel) : Prop :=
-  IsDefEqStrong env U Γ e e A u
-
-def IsType (env : VEnv') (U : Nat) (Γ : VCtx) (A : VExpr) (u : VLevel) : Prop :=
-  env.HasType U Γ A (.sort u) (.succ u)
-
-def VConstant.WF (env : VEnv') (ci : VConstant) : Prop := env.IsType ci.uvars [] ci.type ci.level
-
-def VDefEq.WF (env : VEnv') (df : VDefEq) : Prop :=
-  env.HasType df.uvars [] df.lhs df.type df.level ∧ env.HasType df.uvars [] df.rhs df.type df.level
-
-def addConst (env : VEnv') (name : Name) (ci : VConstant) : Option VEnv' :=
-  match env.constants name with
-  | some _ => none
-  | none => some { env with constants := fun n => if name = n then some ci else env.constants n }
-
-theorem addConst_out {env : VEnv'} (H : env.addConst n ci = some env₂) :
-    env.out.addConst n ci.toVConstant = some env₂.out := by
-  revert H; simp [addConst, VEnv.addConst, VEnv'.out]
-  cases env.constants n <;> simp
-  rintro rfl; simp; ext x; split <;> simp
-
-theorem constants_out {env : VEnv'} (H : env.constants n = some ci) :
-    env.out.constants n = some ci.toVConstant := by simp [VEnv'.out, H]
-
-theorem defeqs_out {env : VEnv'} (H : env.defeqs df) :
-    env.out.defeqs df.toVDefEq := ⟨_, H, rfl⟩
-
-def addDefEq (env : VEnv') (df : VDefEq) : VEnv' :=
-  { env with defeqs := fun x => x = df ∨ env.defeqs x }
-
-@[simp] theorem addDefEq_out {env : VEnv'} :
-    (env.addDefEq df).out = env.out.addDefEq df.toVDefEq := by
-  simp [VEnv'.out, addDefEq, VEnv.addDefEq]
-
-theorem IsDefEqStrong.hasType {env : VEnv'}
-    (H : env.IsDefEqStrong U Γ e1 e2 A u) :
-    env.IsDefEqStrong U Γ e1 e1 A u ∧ env.IsDefEqStrong U Γ e2 e2 A u :=
-  ⟨H.trans H.symm, H.symm.trans H⟩
-
-inductive Ctx.LiftN (n : Nat) : Nat → VCtx → VCtx → Prop where
-  | zero (As : VCtx) (h : As.length = n := by rfl) : Ctx.LiftN n 0 Γ (As ++ Γ)
-  | succ : Ctx.LiftN n k Γ Γ' → Ctx.LiftN n (k+1) ((A, u)::Γ) ((A.liftN n k, u) :: Γ')
-
-theorem Lookup.weakN (W : Ctx.LiftN n k Γ Γ') (H : Lookup Γ i A u) :
-    Lookup Γ' (liftVar n i k) (A.liftN n k) u := by
-  induction W generalizing i A u with
-  | zero As =>
-    rw [liftVar_base, Nat.add_comm]
-    subst n
-    induction As with simp [*]
-    | cons _ _ ih => rw [liftN_succ]; exact .succ ih
-  | @succ k _ _ _ _ _ ih =>
-    match H with
-    | .zero => rw [liftVar_zero, ← lift_liftN']; exact .zero
-    | .succ H => rw [liftVar_succ, ← lift_liftN']; exact (ih H).succ
-
-theorem Lookup.out (H : Lookup Γ n ty u) : Lean4Lean.Lookup Γ.out n ty := by
-  induction H with
-  | zero => exact .zero
-  | succ _ ih => exact .succ ih
-
-theorem IsDefEqStrong.out
-    (H : IsDefEqStrong env U Γ e1 e2 A u) : env.out.IsDefEq U Γ.out e1 e2 A := by
-  induction H with
-  | bvar h => exact .bvar h.out
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | constDF h1 h2 h3 h4 h5 => exact .constDF (constants_out h1) h2 h3 h4 h5
-  | appDF _ _ _ _ _ _ _ _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ _ _ _ _ _ ih1 _ _ ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ _ _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF _ _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  | defeqL _ _ _ _ ih => exact ih
-  | beta _ _ _ _ _ _ _ _ _ _ ih1 ih2 => exact .beta ih1 ih2
-  | eta _ _ _ _ _ _ _ _ _ _ ih => exact .eta ih
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 h3 => exact .extra (defeqs_out h1) h2 h3
-
-nonrec theorem HasType.out (H : HasType env U Γ e A u) : env.out.HasType U Γ.out e A := H.out
-
-nonrec theorem IsType.out (H : IsType env U Γ A u) : env.out.IsType U Γ.out A :=
-  ⟨_, H.out⟩
-
-nonrec theorem VConstant.WF.out {ci : VConstant} (H : ci.WF env) : ci.toVConstant.WF env.out :=
-  H.out
-
-theorem VDefEq.WF.out {ci : VDefEq} (H : ci.WF env) : ci.toVDefEq.WF env.out :=
-  ⟨H.1.out, H.2.out⟩
-
-inductive Ordered : VEnv' → Prop where
-  | empty : Ordered ∅
-  | const :
-    Ordered env → ci.WF env →
-    env.addConst n ci = some env' → Ordered env'
-  | defeq : Ordered env → df.WF env → Ordered (env.addDefEq df)
-
-theorem Ordered.out (H : Ordered env) : env.out.Ordered := by
-  induction H with
-  | empty => simp; exact .empty
-  | const h1 h2 h3 ih => exact .const ih h2.out (addConst_out h3)
-  | defeq h1 h2 ih => exact addDefEq_out ▸ .defeq ih h2.out
-
-def OnTypes (env : VEnv') (P : Nat → VExpr → VExpr → VLevel → Prop) : Prop :=
-  (∀ {n ci}, env.constants n = some ci →
-    P ci.uvars ci.type (.sort ci.level) (.succ ci.level)) ∧
-  (∀ {df}, env.defeqs df → P df.uvars df.lhs df.type df.level ∧ P df.uvars df.rhs df.type df.level)
-
-variable! (henv : Ordered env) in
-theorem IsDefEqStrong.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEqStrong U Γ e1 e2 A u) :
-    env.IsDefEqStrong U Γ' (e1.liftN n k) (e2.liftN n k) (A.liftN n k) u := by
-  induction H generalizing k Γ' with
-  | bvar h1 h2 _ ih3 => refine .bvar (h1.weakN W) h2 (ih3 W)
-  | symm _ ih => exact .symm (ih W)
-  | trans _ _ ih1 ih2 => exact .trans (ih1 W) (ih2 W)
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | constDF h1 h2 h3 h4 h5 h6 h7 h8 h9 _ _ _ _ ih3 ih4 =>
-    simp [(henv.out.closedC (constants_out h1)).instL.liftN_eq (Nat.zero_le _)] at ih3 ih4 ⊢
-    exact .constDF h1 h2 h3 h4 h5 h6 h7 h8 h9 (ih3 W) (ih4 W)
-  | appDF h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    refine liftN_inst_hi .. ▸ .appDF h1 h2 (ih1 W) (ih2 W.succ) (ih3 W) (ih4 W) ?_
-    exact liftN_inst_hi .. ▸ liftN_inst_hi .. ▸ ih5 W
-  | lamDF h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact .lamDF h1 h2 (ih1 W) (ih2 W.succ) (ih3 W.succ) (ih4 W.succ) (ih5 W.succ)
-  | forallEDF h1 h2 _ _ _ ih1 ih2 ih3 => exact .forallEDF h1 h2 (ih1 W) (ih2 W.succ) (ih3 W.succ)
-  | defeqDF h1 _ _ ih1 ih2 => exact .defeqDF h1 (ih1 W) (ih2 W)
-  | defeqL h1 h2 h3 _ ih => exact .defeqL h1 h2 h3 (ih W)
-  | beta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 =>
-    refine liftN_inst_hi .. ▸ liftN_instN_hi .. ▸ .beta h1 h2
-      (ih1 W) (ih2 W.succ) (ih3 W.succ) (ih4 W)
-      (liftN_instN_hi .. ▸ ih5 W :)
-      (liftN_instN_hi .. ▸ liftN_instN_hi .. ▸ ih6 W :)
-  | @eta Γ a u B v e h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    have := IsDefEqStrong.eta h1 h2 (ih1 W) (ih2 W.succ) ?_ (ih4 W) ?_
-    · simp [liftN]; rwa [← lift_liftN']
-    · specialize ih3 W.succ.succ
-      have := liftN'_comm B n 1 (k+1) 1 (Nat.le_add_left ..)
-      rw [Nat.add_comm 1] at this; rwa [← this, ← lift_liftN'] at ih3
-    · have ih5 : IsDefEqStrong _ _ _ _ _ (liftN n (lift (forallE ..)) _) _ := ih5 W.succ
-      rwa [← lift_liftN', ← lift_liftN'] at ih5
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
-  | extra h1 h2 h3 h4 h5 h6 h7 h8 _ _ _ _ _ ih4 ih5 =>
-    have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.out.closed.2 (defeqs_out h1)
-    simp [
-      hA1.instL.liftN_eq (Nat.zero_le _),
-      hA2.instL.liftN_eq (Nat.zero_le _),
-      hA3.instL.liftN_eq (Nat.zero_le _)] at ih4 ih5 ⊢
-    exact IsDefEqStrong.extra h1 h2 h3 h4 h5 h6 h7 h8 (ih4 W) (ih5 W)
-
-variable! {env env' : VEnv'} (henv : env ≤ env') in
-theorem IsDefEqStrong.mono
-    (H : env.IsDefEqStrong U Γ e1 e2 A u) : env'.IsDefEqStrong U Γ e1 e2 A u := by
-  induction H with
-  | bvar h1 h2 _ ih => exact .bvar h1 h2 ih
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | constDF h1 h2 h3 h4 h5 h6 h7 _ _ _ _ ih1 ih2 ih3 ih4 =>
-    exact .constDF (henv.1 h1) h2 h3 h4 h5 h6 h7 ih1 ih2 ih3 ih4
-  | appDF h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 => exact .appDF h1 h2 ih1 ih2 ih3 ih4 ih5
-  | lamDF h1 h2  _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 => exact .lamDF h1 h2 ih1 ih2 ih3 ih4 ih5
-  | forallEDF h1 h2 _ _ _ ih1 ih2 ih3 => exact .forallEDF h1 h2 ih1 ih2 ih3
-  | defeqDF h1 _ _ ih1 ih2 => exact .defeqDF h1 ih1 ih2
-  | defeqL h1 h2 h3 _ ih => exact .defeqL h1 h2 h3 ih
-  | beta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 => exact .beta h1 h2 ih1 ih2 ih3 ih4 ih5 ih6
-  | eta h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 => exact .eta h1 h2 ih1 ih2 ih3 ih4 ih5
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 h3 h4 h5 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact .extra (henv.2 h1) h2 h3 h4 h5 ih1 ih2 ih3 ih4 ih5
-
-variable! (henv : Ordered env) in
-theorem IsDefEqStrong.weak0 (H : env.IsDefEqStrong U [] e1 e2 A u) :
-    env.IsDefEqStrong U Γ e1 e2 A u := by
-  have ⟨h1, h2, h3⟩ := H.out.closedN' henv.out.closed ⟨⟩
-  simpa [h1.liftN_eq (Nat.zero_le _), h2.liftN_eq (Nat.zero_le _),
-    h3.liftN_eq (Nat.zero_le _)] using H.weakN henv (.zero Γ rfl)
-
-def VCtx.instL (ls : List VLevel) : VCtx → VCtx := List.map fun (A, u) => (A.instL ls, u.inst ls)
-
-theorem Lookup.instL : Lookup Γ i A u → Lookup (Γ.instL ls) i (A.instL ls) (u.inst ls)
-  | .zero => instL_liftN ▸ .zero
-  | .succ h => instL_liftN ▸ .succ h.instL
-
-variable! {env : VEnv'} {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') in
-theorem IsDefEqStrong.instL (H : env.IsDefEqStrong U Γ e1 e2 A u) :
-    env.IsDefEqStrong U' (Γ.instL ls) (e1.instL ls) (e2.instL ls) (A.instL ls) (u.inst ls) := by
-  induction H with
-  | bvar h _ _ ih =>
-    exact .bvar h.instL (.inst hls) ih
-  | constDF h1 h2 h3 h4 h5 h6 _ _ _ _ _ ih1 ih2 ih3 ih4 =>
-    simp [VExpr.instL, VExpr.instL_instL] at ih1 ih2 ih3 ih4 ⊢
-    exact .constDF h1
-      (by simp [VLevel.WF.inst hls]) (by simp [VLevel.WF.inst hls]) (by simp [h4])
-      (by simpa using h5.imp fun _ _ => VLevel.inst_congr_l)
-      (VLevel.inst_inst ▸ VLevel.inst_congr_l h6) (.inst hls) ih1 ih2 ih3 ih4
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sortDF _ _ h3 =>
-    exact .sortDF (VLevel.WF.inst hls) (VLevel.WF.inst hls) (VLevel.inst_congr_l h3)
-  | appDF _ _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact instL_instN ▸ .appDF (.inst hls) (.inst hls)
-      ih1 ih2 ih3 ih4 (instL_instN ▸ instL_instN ▸ ih5)
-  | lamDF _ _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact .lamDF (.inst hls) (.inst hls) ih1 ih2 ih3 ih4 ih5
-  | forallEDF _ _ _ _ _ ih1 ih2 ih3 =>
-    exact .forallEDF (.inst hls) (.inst hls) ih1 ih2 ih3
-  | defeqDF _ _ _ ih1 ih2 => exact .defeqDF (.inst hls) ih1 ih2
-  | defeqL _ _ h3 _ ih => exact .defeqL (.inst hls) (.inst hls) (VLevel.inst_congr_l h3) ih
-  | beta _ _ _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 =>
-    simpa using .beta (.inst hls) (.inst hls) ih1 ih2 ih3 ih4
-      (by simpa [VExpr.instL, VLevel.inst] using ih5)
-      (by simpa [VExpr.instL, VLevel.inst] using ih6)
-  | eta _ _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    simpa [VExpr.instL] using .eta (.inst hls) (.inst hls) ih1 ih2
-      (by simpa [VCtx.instL, VExpr.instL, VLevel.inst] using ih3) ih4
-      (by simpa [VCtx.instL, VExpr.instL, VLevel.inst] using ih5)
-  | proofIrrel _ _ _ ih1 ih2 ih3 =>
-    exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 h3 h4 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    simp [VExpr.instL, VExpr.instL_instL] at ih1 ih2 ih3 ih4 ih5 ⊢
-    exact .extra h1 (by simp [VLevel.WF.inst hls]) (by simp [h3])
-      (VLevel.inst_inst ▸ VLevel.inst_congr_l h4) (.inst hls) ih1 ih2 ih3 ih4 ih5
-
-def VCtx.On (Γ : VCtx) (P : VCtx → VExpr → VLevel → Prop) : Prop :=
-  match Γ with
-  | [] => True
-  | (A, u)::Γ => On Γ P ∧ P Γ A u
-
-def CtxStrong (env : VEnv') (U) (Γ : VCtx) :=
-  Γ.On fun Γ A u => env.IsDefEqStrong U Γ A A (.sort u) (.succ u)
-
-theorem VCtx.On.lookup (h : On Γ P) (hL : Lookup Γ n A u)
-    (hP : ∀ {Γ A B u}, P Γ A u → P (B::Γ) A.lift u) : P Γ A u :=
-  match hL, h with
-  | .zero, ⟨h1, h2⟩ => hP h2
-  | .succ hL, ⟨h1, h2⟩ => hP (h1.lookup hL hP)
-
-variable! (henv : Ordered env) in
-nonrec theorem CtxStrong.lookup {Γ} (H : CtxStrong env U Γ) (h : Lookup Γ i A u) :
-    env.IsDefEqStrong U Γ A A (.sort u) (.succ u) :=
-  H.lookup h fun h => h.weakN henv (.zero [_])
-
-theorem VCtx.On.mono (H : ∀ {Γ A u}, P Γ A u → Q Γ A u) : ∀ {Γ}, On Γ P → On Γ Q
-  | [], h => h
-  | _::_, ⟨h1, h2⟩ => ⟨mono H h1, H h2⟩
-
-theorem CtxStrong.out : ∀ {Γ}, CtxStrong env U Γ → OnCtx Γ.out (env.out.IsType U)
-  | [], h => h
-  | _::_, ⟨h1, h2⟩ => ⟨out h1, _, h2.out⟩
-
-variable (Γ₀ : VCtx) (e₀ A₀ : VExpr) (u₀ : VLevel) in
-inductive Ctx.InstN' : Nat → VCtx → VCtx → Prop where
-  | zero : Ctx.InstN' 0 ((A₀, u₀) :: Γ₀) Γ₀
-  | succ : Ctx.InstN' k Γ Γ' → Ctx.InstN' (k+1) ((A, u)::Γ) ((A.inst e₀ k, u) :: Γ')
-
-variable! (henv : Ordered env) (h₀ : env.IsDefEqStrong U Γ₀ e₀ e₀ A₀ u₀)
-  (hΓ₀ : CtxStrong env U Γ₀) in
-theorem IsDefEqStrong.instN (W : Ctx.InstN' Γ₀ e₀ A₀ u₀ k Γ₁ Γ)
-    (H : env.IsDefEqStrong U Γ₁ e1 e2 A u) (hΓ : CtxStrong env U Γ) :
-    env.IsDefEqStrong U Γ (e1.inst e₀ k) (e2.inst e₀ k) (A.inst e₀ k) u := by
-  induction H generalizing Γ k with
-  | @bvar _ i ty _ h _ h2 ih =>
-    dsimp [inst]; clear h2 ih
-    induction W generalizing i ty with
-    | zero =>
-      cases h with simp [inst_lift]
-      | zero => exact h₀
-      | succ h =>
-        have hty := hΓ₀.lookup henv h
-        exact .bvar h (hty.out.sort_r henv.out hΓ₀.out) hty
-    | succ _ ih =>
-      cases h with (simp; rw [Nat.add_comm, ← liftN_instN_lo (hj := Nat.zero_le _)])
-      | zero =>
-        have hty := hΓ.lookup henv .zero
-        exact .bvar .zero (hty.out.sort_r henv.out hΓ.out) hty
-      | succ h => exact (ih h hΓ.1).weakN henv (.zero [_])
-  | symm _ ih => exact .symm (ih W hΓ)
-  | trans _ _ ih1 ih2 => exact .trans (ih1 W hΓ) (ih2 W hΓ)
-  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
-  | constDF h1 h2 h3 h4 h5 h6 h7 h8 h9 _ _ _ _ ih3 ih4 =>
-    simp [(henv.out.closedC (constants_out h1)).instL.instN_eq (Nat.zero_le _)] at ih3 ih4 ⊢
-    exact .constDF h1 h2 h3 h4 h5 h6 h7 h8 h9 (ih3 W hΓ) (ih4 W hΓ)
-  | appDF h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact inst0_inst_hi .. ▸ .appDF h1 h2
-      (ih1 W hΓ) (ih2 W.succ ⟨hΓ, ih1 W hΓ⟩)
-      (ih3 W hΓ) (ih4 W hΓ) (inst0_inst_hi .. ▸ inst0_inst_hi .. ▸ ih5 W hΓ)
-  | lamDF h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    exact
-      have hΓ' := ⟨hΓ, (ih1 W hΓ).hasType.1⟩
-      have hΓ'' := ⟨hΓ, (ih1 W hΓ).hasType.2⟩
-      .lamDF h1 h2 (ih1 W hΓ) (ih2 W.succ hΓ') (ih3 W.succ hΓ'') (ih4 W.succ hΓ') (ih5 W.succ hΓ'')
-  | forallEDF h1 h2 _ _ _ ih1 ih2 ih3 =>
-    exact .forallEDF h1 h2 (ih1 W hΓ)
-      (ih2 W.succ ⟨hΓ, (ih1 W hΓ).hasType.1⟩) (ih3 W.succ ⟨hΓ, (ih1 W hΓ).hasType.2⟩)
-  | defeqDF h1 _ _ ih1 ih2 => exact .defeqDF h1 (ih1 W hΓ) (ih2 W hΓ)
-  | defeqL h1 h2 h3 _ ih => exact .defeqL h1 h2 h3 (ih W hΓ)
-  | beta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 =>
-    rw [inst0_inst_hi, inst0_inst_hi]; exact
-      have hΓ' := ⟨hΓ, ih1 W hΓ⟩
-      .beta h1 h2
-        (ih1 W hΓ) (ih2 W.succ hΓ') (ih3 W.succ hΓ') (ih4 W hΓ)
-        (inst0_inst_hi .. ▸ ih5 W hΓ) (inst0_inst_hi .. ▸ inst0_inst_hi .. ▸ ih6 W hΓ)
-  | eta h1 h2 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
-    have :=
-      have hΓ' := ⟨hΓ, (ih1 W hΓ).hasType.1⟩
-      IsDefEqStrong.eta h1 h2 (ih1 W hΓ) (ih2 W.succ hΓ')
-        (by
-          have := ih3 W.succ.succ ⟨hΓ', by
-            rw [← lift_instN_lo]; exact (ih1 W hΓ).hasType.1.weakN henv (.zero [_])⟩
-          rwa [lift_instN_lo, liftN_instN_lo (hj := Nat.le_add_left ..), Nat.add_comm 1])
-        (ih4 W hΓ)
-        (by
-          have := ih5 W.succ hΓ'
-          simp only [inst, ← lift_instN_lo] at this
-          rwa [liftN_instN_lo (hj := Nat.le_add_left ..), Nat.add_comm 1])
-    rw [lift, liftN_instN_lo (hj := Nat.zero_le _), Nat.add_comm] at this
-    simpa [inst]
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W hΓ) (ih2 W hΓ) (ih3 W hΓ)
-  | extra h1 h2 h3 h4 h5 h6 h7 h8 _ _ _ _ _ ih4 ih5 =>
-    have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.out.closed.2 (defeqs_out h1)
-    simp [
-      hA1.instL.instN_eq (Nat.zero_le _),
-      hA2.instL.instN_eq (Nat.zero_le _),
-      hA3.instL.instN_eq (Nat.zero_le _)] at ih4 ih5 ⊢
-    exact .extra h1 h2 h3 h4 h5 h6 h7 h8 (ih4 W hΓ) (ih5 W hΓ)
-
-theorem IsDefEqStrong.defeqDF_l (henv : Ordered env) (hΓ : CtxStrong env U Γ)
-    (h1 : env.IsDefEqStrong U Γ A A' (.sort u) (.succ u))
-    (h2 : env.IsDefEqStrong U ((A, u)::Γ) e1 e2 B v) :
-    env.IsDefEqStrong U ((A', u)::Γ) e1 e2 B v := by
-  simpa [instN_bvar0] using
-    have hu := h1.out.sort_r henv.out hΓ.out
-    have hΓ' := ⟨hΓ, h1.hasType.2⟩
-    h1.weakN henv (.zero [(A', u)])
-      |>.symm.defeqDF hu (.bvar .zero hu (h1.hasType.2.weakN henv (.zero [(A', u)])))
-      |>.instN henv hΓ' .zero (h2.weakN henv (.succ (.zero [(A', u)]))) hΓ'
-
-def EnvStrong (env : VEnv') (U : Nat) (e A : VExpr) (u : VLevel) : Prop :=
-  env.IsDefEqStrong U [] e e A u ∧
-  env.IsDefEqStrong U [] A A (.sort u) (.succ u) ∧
-  ∀ A B, e = A.forallE B →
-    ∃ u, env.IsDefEqStrong U [] A A (.sort u) (.succ u) ∧
-    ∃ v, env.IsDefEqStrong U [(A, u)] B B (.sort v) (.succ v)
-
-variable! (henv : Ordered env) (envIH : env.OnTypes (EnvStrong env)) in
-theorem IsDefEqStrong.forallE_inv' (hΓ : CtxStrong env U Γ)
-    (H : env.IsDefEqStrong U Γ e1 e2 V v) (eq : e1 = A.forallE B ∨ e2 = A.forallE B) :
-    ∃ u, env.IsDefEqStrong U Γ A A (.sort u) (.succ u) ∧
-    ∃ v, env.IsDefEqStrong U ((A, u)::Γ) B B (.sort v) (.succ v) := by
-  induction H generalizing A B with
-  | symm _ ih => exact ih hΓ eq.symm
-  | trans _ _ ih1 ih2
-  | proofIrrel _ _ _ _ ih1 ih2 =>
-    obtain eq | eq := eq
-    · exact ih1 hΓ (.inl eq)
-    · exact ih2 hΓ (.inr eq)
-  | forallEDF _ _ h1 h2 =>
-    obtain ⟨⟨⟩⟩ | ⟨⟨⟩⟩ := eq
-    · exact ⟨_, h1.hasType.1, _, h2.hasType.1⟩
-    · exact ⟨_, h1.hasType.2, _, h1.defeqDF_l henv hΓ h2.hasType.2⟩
-  | defeqDF _ _ _ _ ih | defeqL _ _ _ _ ih => exact ih hΓ eq
-  | @beta _ _ _ _ _ e _ _ _ h1 _ _ h4 _ _ _ _ ih3 ih4 =>
-    obtain ⟨⟨⟩⟩ | eq := eq
-    cases e with
-    | bvar i =>
-      cases i with simp [inst] at eq
-      | zero => exact ih4 hΓ (.inl eq)
-    | forallE A B =>
-      cases eq
-      let ⟨_, A1, _, A2⟩ := ih3 ⟨hΓ, h1⟩ (.inl rfl)
-      refine ⟨_, h4.instN henv hΓ .zero A1 hΓ, _, h4.instN henv hΓ (.succ .zero) A2 ?_⟩
-      exact ⟨hΓ, h4.instN henv hΓ .zero A1 hΓ⟩
-    | _ => cases eq
-  | eta _ _ _ _ _ _ _ _ _ _ ih =>
-    obtain ⟨⟨⟩⟩ | eq := eq
-    exact ih hΓ (.inl eq)
-  | @extra df ls _ Γ h1 h2 =>
-    suffices ∀ e, VExpr.instL ls e = VExpr.forallE A B →
-        EnvStrong env df.uvars e df.type df.level →
-        ∃ u, IsDefEqStrong env U Γ A A (.sort u) (.succ u) ∧
-        ∃ v, IsDefEqStrong env U ((A, u) :: Γ) B B (.sort v) (.succ v) by
-      have ⟨A1, A2⟩ := envIH.2 h1
-      cases eq <;> exact this _ ‹_› ‹_›
-    intro e eq IH
-    cases e <;> cases eq; rename_i A B
-    let ⟨_, A1, v, A2⟩ := IH.2.2 _ _ rfl
-    refine ⟨_, (A1.instL h2).weak0 henv, v.inst ls, ?_⟩
-    have := (A2.instL h2).weakN henv (.succ (.zero Γ))
-    have C1 := (A1.instL h2).out.closedN henv.out ⟨⟩
-    have C2 := (A2.instL h2).out.closedN henv.out ⟨⟨⟩, C1⟩
-    rw [C1.liftN_eq (Nat.zero_le _), C2.liftN_eq (by exact Nat.le_refl _)] at this
-    simpa [liftN]
-  | _ => nomatch eq
-
-variable! (henv : Ordered env) in
-theorem IsDefEqStrong.isType' (hΓ : CtxStrong env U Γ) (H : env.IsDefEqStrong U Γ e1 e2 A u) :
-    env.IsDefEqStrong U Γ A A (.sort u) (.succ u) := by
-  induction H with
-  | bvar h => exact hΓ.lookup henv h
-  | symm _ ih => exact ih hΓ
-  | trans _ _ ih1 => exact ih1 hΓ
-  | sortDF h1 => exact .sortDF h1 h1 rfl
-  | constDF _ _ _ _ _ _ _ _ _ h => exact h
-  | appDF _ _ _ _ _ _ h4 _ _ _ ih3 => exact h4.hasType.1
-  | lamDF h1 h2 h3 h4 => exact .forallEDF h1 h2 h3.hasType.1 h4 h4
-  | forallEDF h1 h2 => exact .sortDF ⟨h1, h2⟩ ⟨h1, h2⟩ rfl
-  | defeqDF _ h2 => exact h2.hasType.2
-  | defeqL h1 h2 h3 _ ih =>
-    exact (defeqDF (by exact h1) (sortDF h1 h2 h3) (ih hΓ))
-      |>.defeqL (by exact h1) (by exact h2) (VLevel.succ_congr h3)
-  | beta _ _ _ h4 _ h6 => exact h6.hasType.1.instN henv hΓ .zero h4 hΓ
-  | eta _ _ _ _ _ _ _ _ _ _ ih => exact ih hΓ
-  | proofIrrel h1 => exact h1
-  | extra _ _ _ _ _ h => exact h.weak0 henv
-
-theorem IsDefEqStrong.sort_invL {env : VEnv'}
-    (H : env.IsDefEqStrong U Γ e1 e2 A u) :
-    (.sort v = e1 → u ≈ v.succ.succ) ∧
-    (.sort v = e2 → u ≈ v.succ.succ) ∧
-    (.sort v = A → u ≈ v.succ) := by
-  induction H generalizing v with
-  | bvar _ _ _ ih
-  | constDF _ _ _ _ _ _ _ _ _ _ _ _ _ ih
-  | appDF _ _ _ _ _ _ _ _ _ _ _ ih =>
-    exact ⟨nofun, nofun, fun h => VLevel.succ_congr_iff.1 <| ih.1 h⟩
-  | symm _ ih => exact ⟨ih.2.1, ih.1, ih.2.2⟩
-  | trans _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2.1, ih1.2.2⟩
-  | sortDF _ _ h =>
-    refine ⟨by rintro ⟨⟩; rfl, ?_, by rintro ⟨⟩; rfl⟩
-    rintro ⟨⟩; exact VLevel.succ_congr (VLevel.succ_congr h)
-  | lamDF => exact ⟨nofun, nofun, nofun⟩
-  | forallEDF => exact ⟨nofun, nofun, by rintro ⟨⟩; rfl⟩
-  | defeqDF _ _ _ ih1 ih2 => exact ⟨ih2.1, ih2.2.1, fun h => VLevel.succ_congr_iff.1 <| ih1.2.1 h⟩
-  | defeqL _ _ h1 _ ih =>
-    exact ⟨h1.symm.trans ∘ ih.1, h1.symm.trans ∘ ih.2.1, h1.symm.trans ∘ ih.2.2⟩
-  | beta _ _ _ _ _ _ _ _ _ _ _ _ _ ih => exact ⟨nofun, ih.1, ih.2.2⟩
-  | eta _ _ _ _ _ _ _ _ _ _ ih => exact ⟨nofun, ih.1, ih.2.2⟩
-  | proofIrrel _ _ _ _ ih1 ih2
-  | extra _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 => exact ⟨ih1.1, ih2.1, ih1.2.2⟩
-
-variable {env : VEnv'} in
--- variable! (henv : Ordered env) (hΓ : CtxStrong env U Γ) in
-theorem IsDefEqStrong.uniqL'
-    (H1 : env.IsDefEqStrong U Γ e1 e2 A u)
-    (H2 : env.IsDefEqStrong U Γ e1' e2' A' v)
-    : (e1 = e1' → u ≈ v) ∧ (e1 = e2' → u ≈ v) ∧
-      (e2 = e1' → u ≈ v) ∧ (e2 = e2' → u ≈ v) := by
-  induction H1 generalizing e1' e2' A' v with
-  | bvar H1 h1 h2 ih =>
-    clear h1 h2 ih
-    induction H2 with try simp
-    | @bvar _ _ A' u' H2 h1 h2 ih =>
-      rintro rfl; clear h1 h2 ih
-      induction H1 generalizing A' u' with cases H2
-      | zero => rfl
-      | succ h ih => exact ih ‹_›
-    | symm _ ih => let ⟨h1, h2, h3, h4⟩ := ih H1; exact ⟨h2, h1, h4, h3⟩
-    | trans _ _ ih1 ih2
-    | proofIrrel _ _ _ _ ih1 ih2
-    | extra _ _ _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 =>
-      let ⟨h1, _, h3, _⟩ := ih1 H1; let ⟨_, h2, _, h4⟩ := ih2 H1
-      exact ⟨h1, h2, h3, h4⟩
-    | defeqDF _ _ _ _ ih => exact ih H1
-    | defeqL _ _ h _ ih => exact propext (VLevel.equiv_congr_right h) ▸ ih H1
-    | beta _ _ _ _ _ _ _ _ _ _ _ _ _ ih
-    | eta _ _ _ _ _ _ _ _ _ _ ih => exact (ih H1).1
-  | @constDF c ci ls _ _ _ h1 _ _ _ h2 hu _ d1 d2 d3 d4 ih1 ih2 ih3 ih4 =>
-    clear d1 d2 d3 d4 ih1 ih2 ih3 ih4
-    induction H2 with try simp
-    | @constDF c' _ ls' _ _ _ h1' _ _ _ h2' hu' =>
-      by_cases h : c = c' <;> simp [h]; subst h
-      cases h1.symm.trans h1'
-      rw [VLevel.equiv_congr_left hu, VLevel.equiv_congr_right hu']
-      have eq := VLevel.inst_congr (l := ci.level) rfl h2
-      have eq' := VLevel.inst_congr (l := ci.level) rfl h2'
-      refine ⟨?_, ?_, ?_, ?_⟩ <;> rintro rfl <;>
-        [rfl; exact eq'.symm; exact eq; exact eq.trans eq'.symm]
-    | symm _ ih => let ⟨h1, h2, h3, h4⟩ := ih; exact ⟨h2, h1, h4, h3⟩
-    | trans _ _ ih1 ih2
-    | proofIrrel _ _ _ _ ih1 ih2
-    | extra _ _ _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 =>
-      let ⟨h1, _, h3, _⟩ := ih1; let ⟨_, h2, _, h4⟩ := ih2
-      exact ⟨h1, h2, h3, h4⟩
-    | defeqDF _ _ _ _ ih => exact ih
-    | defeqL _ _ h _ ih => exact propext (VLevel.equiv_congr_right h) ▸ ih
-    | beta _ _ _ _ _ _ _ _ _ _ _ _ _ ih
-    | eta _ _ _ _ _ _ _ _ _ _ ih => exact ⟨ih.1, ih.2.2.1⟩
-  | @appDF _ _ _ _ _ f₁ f₂ a₁ a₂ _ _ d1 d2 d3 d4 d5 ih1 ih2 ih3 ih4 ih5 =>
-    clear d1 d2 d3 d4 d5 ih1 ih2 ih5
-    induction H2 with try simp
-    | @appDF _ _ _ _ _ f₁' f₂' a₁' a₂' _ _ _ _ _ ih3' ih4' =>
-      refine ⟨?_, sorry⟩
-      rintro rfl rfl
-      sorry -- looks like it needs unique typing :(
-    | _ => sorry
-  | _ => sorry
+This abandoned environment redesign predates registered structure eta,
+contains its own admissions, and has no consumers.  It is intentionally
+parked as an import-compatible stub instead of being adapted into the
+L4L-16 trust path.
+-/
diff --git a/Lean4Lean/Experimental/Thierry2.lean b/Lean4Lean/Experimental/Thierry2.lean
index 86eb589b..68de65ec 100644
--- a/Lean4Lean/Experimental/Thierry2.lean
+++ b/Lean4Lean/Experimental/Thierry2.lean
@@ -18,7 +18,7 @@ inductive ShapeS (Shape : Type) : Type where
   | pi : Shape → List (Shape × Shape) → ShapeS Shape
   | lam : List (Shape × Shape) → ShapeS Shape
 
-def Shape : Nat → Type
+@[implicit_reducible] def Shape : Nat → Type
   | 0 => Shape0
   | n + 1 => ShapeS (Shape n)
 
diff --git a/Lean4Lean/Experimental/UniqueTyping.lean b/Lean4Lean/Experimental/UniqueTyping.lean
index 74bf5830..c7a43e07 100644
--- a/Lean4Lean/Experimental/UniqueTyping.lean
+++ b/Lean4Lean/Experimental/UniqueTyping.lean
@@ -1,266 +1,31 @@
 import Lean4Lean.Experimental.ShapeLogRelAdequacy
 
-/-! # Unique typing over the SExpr weak defeq.
-
-We work over `SExpr.IsDefEq` (a.k.a. `=W`), which has a heterogeneous
-transitivity rule `trans'` allowing the middle term to live at a different
-sort. Using `sort_inv` and `forallE_inv` from `ShapeLogRelAdequacy`, we
-prove type uniqueness up to defeq, without needing stratified judgments.
-
-From this we derive `uniq_sort` and admit a no-`trans'` variant `IsDefEq'`. -/
+/-! # Strong sort uniqueness
+
+The former contents of this module attempted to recover an
+`IsDefEqStrong` derivation from weak `SExpr.IsDefEq`.  That direction loses
+the typing and extension certificates carried by the strong judgment and is
+not valid for the current proof-carrying interface.
+
+L4L-16 needs the converse architecture: translate the live Theory strong
+judgment directly, then run semantic adequacy on that evidence.  The
+resulting sort-injectivity theorem is re-exported here under the old
+`uniq_sort` spelling.  General type uniqueness and elimination of weak
+heterogeneous transitivity remain L4L-17 work.
+-/
 
 namespace Lean4Lean
-open Params
 namespace SExpr
-variable [Params]
-
-section
-set_option hygiene false
-local notation:65 Γ " ⊨ " e " : " A:36 => HasTypeS Γ e A true
-local notation:65 Γ " ⊨ " e " :! " A:36 => HasTypeS Γ e A false
-
-/--
-Bundled SExpr typing judgment. `Γ ⊨ e : A` (`b = true`) allows definitional
-equality coercion; `Γ ⊨ e :! A` (`b = false`) is structural-only. This is
-the SExpr analog of `HasTypeStrong` from the VEnv side, stripped of the
-stratification index. Sort witnesses are carried at each constructor so
-that type inversion is a direct structural property.
--/
-inductive HasTypeS : List SExpr → SExpr → SExpr → Bool → Prop where
-  | bvar : Lookup Γ i A → Γ ⊨ A : .sort u → Γ ⊨ .bvar i :! A
-  | sort' : Γ ⊨ .sort l :! .sort (.succ l)
-  | const :
-    env.constants c = some ci → ls.length = ci.uvars →
-    Γ ⊨ (mk ci.type).instL ls : .sort u →
-    Γ ⊨ .const c ls :! (mk ci.type).instL ls
-  | app :
-    Γ ⊨ f : .forallE A B → Γ ⊨ a : A →
-    Γ ⊨ .app f a :! B.inst a
-  | lam :
-    Γ ⊨ A : .sort u → A::Γ ⊨ body : B →
-    Γ ⊨ .lam A body :! .forallE A B
-  | forallE :
-    Γ ⊨ A : .sort u → A::Γ ⊨ body : .sort v →
-    Γ ⊨ .forallE A body :! .sort (.imax u v)
-  | base : Γ ⊨ e :! A → Γ ⊨ e : A
-  | defeq :
-    Γ ⊢ A ≡ B : .sort u → Γ ⊨ e : A → Γ ⊨ e : B
-
-end
-
-scoped notation:65 Γ " ⊨ " e " : " A:36 => HasTypeS Γ e A true
-scoped notation:65 Γ " ⊨ " e " :! " A:36 => HasTypeS Γ e A false
-
-/-- A bundled `HasTypeS` derivation can be projected back to a plain
-`IsDefEq` derivation of reflexivity at the given type. -/
-theorem HasTypeS.hasType : HasTypeS Γ e A b → Γ ⊢ e : A := by
-  intro h
-  induction h with
-  | bvar h _ _ => exact .bvar h
-  | sort' => exact .sort
-  | const h1 h2 _ _ => exact .const h1 h2
-  | app _ _ ihf iha => exact .appDF ihf iha
-  | lam _ _ ihA ihbody => exact ihA.lamDF ihbody
-  | forallE _ _ ihA ihbody => exact .forallEDF ihA ihbody
-  | base _ ih => exact ih
-  | defeq d _ ihe => exact d.defeqDF ihe
-
-/-- Every `b = true` derivation unfolds to a `b = false` (structural) derivation
-together with a transport: any defeq involving the structural type can be
-re-targeted at the original type. -/
-theorem HasTypeS.unfold (h : Γ ⊨ e : A) :
-    ∃ A', (Γ ⊨ e :! A') ∧
-      ∀ {C u}, Γ ⊢ C ≡ A' : .sort u → ∃ u', Γ ⊢ C ≡ A : .sort u' := by
-  generalize hb : true = b at h
-  induction h with cases hb
-  | base h_s => exact ⟨_, h_s, fun input => ⟨_, input⟩⟩
-  | defeq d _ ihe =>
-    obtain ⟨A', h_s, chain⟩ := ihe rfl
-    exact ⟨A', h_s, fun input => let ⟨_, eq⟩ := chain input; ⟨_, eq.trans' d⟩⟩
-
-/-- Reduce any `HasTypeS` derivation (at either `b`) to a structural one with
-a transport function. -/
-theorem HasTypeS.toStructural (h : HasTypeS Γ e A b) :
-    ∃ A', (Γ ⊨ e :! A') ∧
-      ∀ {C u}, Γ ⊢ C ≡ A' : .sort u → ∃ u', Γ ⊢ C ≡ A : .sort u' := by
-  cases b
-  · exact ⟨_, h, fun input => ⟨_, input⟩⟩
-  · exact h.unfold
-
-/-- Type uniqueness up to defeq: any two derivations of `e` give defeq-equivalent
-types. The middle `b` parameters are arbitrary. -/
-theorem HasTypeS.uniq {Γ : List SExpr} {e A B : SExpr} {b₁ b₂ : Bool}
-    (H1 : HasTypeS Γ e A b₁) (H2 : HasTypeS Γ e B b₂) :
-    ∃ u, Γ ⊢ A ≡ B : .sort u := by
-  induction H1 generalizing B b₂ with
-  | bvar h_l h_t _ =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .bvar h_l' _ := H2_s
-    obtain rfl := Lookup.determ h_l h_l'
-    exact transport h_t.hasType
-  | sort' =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .sort' := H2_s
-    exact transport .sort
-  | const h_c _ h_T _ =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .const h_c' _ _ := H2_s
-    obtain rfl := Option.some.inj (h_c.symm.trans h_c')
-    exact transport h_T.hasType
-  | @app Γ' _ A _ a _ h_a ih_f _ =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .app h_f' _ := H2_s
-    obtain ⟨_, h_pi_eq⟩ := ih_f h_f'
-    obtain ⟨_, _, h_A_eq, h_B_eq⟩ := SExpr.forallE_inv h_pi_eq
-    have W : Ctx.SubstEq Γ' (.one a) (.one a) (A :: Γ') :=
-      .cons .nil h_A_eq.hasType.1 (by simpa using h_a.hasType)
-    exact transport (h_B_eq.subst W)
-  | @lam _ _ _ _ body h_A _ _ ih_body =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .lam _ h_body' := H2_s
-    obtain ⟨_, h_B_eq⟩ := ih_body h_body'
-    exact transport (.forallEDF h_A.hasType h_B_eq)
-  | forallE h_A h_b ih_A ih_b =>
-    obtain ⟨_, H2_s, transport⟩ := H2.toStructural
-    let .forallE h_A' h_b' := H2_s
-    obtain ⟨_, h_A_eq⟩ := ih_A h_A'
-    obtain ⟨_, h_b_eq⟩ := ih_b h_b'
-    cases SExpr.sort_inv h_A_eq
-    cases SExpr.sort_inv h_b_eq
-    exact transport .sort
-  | base _ ih_s => exact ih_s H2
-  | defeq d _ ihe =>
-    obtain ⟨_, eq⟩ := ihe H2
-    exact ⟨_, d.symm.trans' eq⟩
-
-/-- Bridge from `IsDefEq` to `HasTypeS`. To be filled in once `IsDefEqStrong`
-is beefed up with the bundled witnesses needed by minimal `HasTypeS`. -/
-theorem IsDefEq.toHasTypeS {Γ : List SExpr} {e₁ e₂ A : SExpr}
-    (h : Γ ⊢ e₁ ≡ e₂ : A) : Γ ⊨ e₁ : A ∧ Γ ⊨ e₂ : A := by
-  replace h := h.strong
-  induction h with
-  | bvar h_l _ ih_A =>
-    refine and_self_iff.2 <| .base <| .bvar h_l ih_A.1
-  | symm _ ih => exact ⟨ih.2, ih.1⟩
-  | trans _ _ _ _ ih1 ih2 => exact ⟨ih1.1, ih2.2⟩
-  | trans' _ _ ih1 ih2 =>
-    obtain ⟨_, eq⟩ := ih1.2.uniq ih2.1
-    cases SExpr.sort_inv eq
-    exact ⟨ih1.1, ih2.2⟩
-  | sort => exact ⟨.base .sort', .base .sort'⟩
-  | const h1 h2 _ _ _ ih_T =>
-    exact and_self_iff.2 <| .base <| .const h1 h2 ih_T.1
-  | appDF _ _ _ h_Ba _ ih_f ih_a ih_Ba =>
-    exact ⟨.base (.app ih_f.1 ih_a.1), .defeq h_Ba.symm.defeq (.base (.app ih_f.2 ih_a.2))⟩
-  | lamDF h_A _ _ _ ih_A ih_B ih_body ih_body' =>
-    refine ⟨.base (.lam ih_A.1 ih_body.1), ?_⟩
-    exact .defeq (.symm <| .forallEDF h_A.defeq ih_B.1.hasType) (.base (.lam ih_A.2 ih_body'.2))
-  | forallEDF _ _ _ ih_A ih_body ih_body' =>
-    exact ⟨.base (.forallE ih_A.1 ih_body.1), .base (.forallE ih_A.2 ih_body'.2)⟩
-  | defeqDF d _ _ ih2 =>
-    exact ⟨.defeq d.defeq ih2.1, .defeq d.defeq ih2.2⟩
-  | beta _ _ _ _ _ _ ih_app ih_inst =>
-    exact ⟨ih_app.1, ih_inst.1⟩
-  | eta _ _ ih_e ih_lam =>
-    exact ⟨ih_lam.1, ih_e.1⟩
-  | proofIrrel _ _ _ _ ih_h ih_h' =>
-    exact ⟨ih_h.1, ih_h'.1⟩
-  | extra _ _ _ _ ih_lhs ih_rhs =>
-    exact ⟨ih_lhs.1, ih_rhs.1⟩
-
-
-/-- Sort uniqueness: if a middle term has two `sort`-types via defeq witnesses,
-the two sort levels coincide. -/
-theorem IsDefEq.uniq_sort {Γ : List SExpr} {e₁ e₂ e₃ : SExpr} {u v : SLevel}
-    (h1 : Γ ⊢ e₁ ≡ e₂ : .sort u) (h2 : Γ ⊢ e₂ ≡ e₃ : .sort v) : u = v := by
-  have ⟨_, h_e2_u⟩ := h1.toHasTypeS
-  have ⟨h_e2_v, _⟩ := h2.toHasTypeS
-  obtain ⟨_, eq⟩ := h_e2_u.uniq h_e2_v
-  exact SExpr.sort_inv eq
-
-/-! ## `IsDefEq'`: defeq without heterogeneous `trans'`
-
-We show that the `trans'` rule is admissible (via `uniq_sort`), so the
-trans'-free system is equivalent to `IsDefEq`. -/
-
-section
-set_option hygiene false
-local notation:65 Γ " ⊢' " e " : " A:36 => IsDefEq' Γ e e A
-local notation:65 Γ " ⊢' " e1 " ≡ " e2 " : " A:36 => IsDefEq' Γ e1 e2 A
-
-/--
-The no-`trans'` variant of `IsDefEq`. Same constructors except the
-heterogeneous transitivity is omitted; it becomes admissible via `uniq_sort`.
--/
-inductive IsDefEq' : List SExpr → SExpr → SExpr → SExpr → Prop where
-  | bvar : Lookup Γ i A → Γ ⊢' .bvar i : A
-  | symm : Γ ⊢' e ≡ e' : A → Γ ⊢' e' ≡ e : A
-  | trans : Γ ⊢' e₁ ≡ e₂ : A → Γ ⊢' e₂ ≡ e₃ : A → Γ ⊢' e₁ ≡ e₃ : A
-  | sort : Γ ⊢' .sort l : .sort (.succ l)
-  | const : env.constants c = some ci → ls.length = ci.uvars →
-    Γ ⊢' .const c ls : (SExpr.mk ci.type).instL ls
-  | appDF : Γ ⊢' f ≡ f' : .forallE A B → Γ ⊢' a ≡ a' : A →
-    Γ ⊢' .app f a ≡ .app f' a' : B.inst a
-  | lamDF : Γ ⊢' A ≡ A' : .sort u → A::Γ ⊢' body ≡ body' : B →
-    Γ ⊢' .lam A body ≡ .lam A' body' : .forallE A B
-  | forallEDF : Γ ⊢' A ≡ A' : .sort u → A::Γ ⊢' body ≡ body' : .sort v →
-    Γ ⊢' .forallE A body ≡ .forallE A' body' : .sort (.imax u v)
-  | defeqDF : Γ ⊢' A ≡ B : .sort u → Γ ⊢' e1 ≡ e2 : A → Γ ⊢' e1 ≡ e2 : B
-  | beta : A::Γ ⊢' e : B → Γ ⊢' e' : A →
-    Γ ⊢' .app (.lam A e) e' ≡ e.inst e' : B.inst e'
-  | eta : Γ ⊢' e : .forallE A B →
-    Γ ⊢' .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B
-  | proofIrrel : Γ ⊢' p : .sort .zero → Γ ⊢' h : p → Γ ⊢' h' : p → Γ ⊢' h ≡ h' : p
-  | extra : env.defeqs df → ls.length = df.uvars →
-    Γ ⊢' .instL ls (.mk df.lhs) ≡ .instL ls (.mk df.rhs) : .instL ls (.mk df.type)
-
-end
-
-scoped notation:65 Γ " ⊢' " e " : " A:36 => IsDefEq' Γ e e A
-scoped notation:65 Γ " ⊢' " e1 " ≡ " e2 " : " A:36 => IsDefEq' Γ e1 e2 A
-
-/-- Forward direction: every `IsDefEq'` derivation embeds into `IsDefEq`. -/
-theorem IsDefEq'.toIsDefEq {Γ : List SExpr} {e₁ e₂ A : SExpr}
-    (h : Γ ⊢' e₁ ≡ e₂ : A) : Γ ⊢ e₁ ≡ e₂ : A := by
-  induction h with
-  | bvar h => exact .bvar h
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | sort => exact .sort
-  | const h1 h2 => exact .const h1 h2
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  | beta _ _ ih1 ih2 => exact .beta ih1 ih2
-  | eta _ ih => exact .eta ih
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 => exact .extra h1 h2
 
-/-- Backward direction: every `IsDefEq` derivation translates to `IsDefEq'`.
-The `trans'` case uses `uniq_sort` to merge sort levels. -/
-theorem IsDefEq.toIsDefEq' {Γ : List SExpr} {e₁ e₂ A : SExpr}
-    (h : Γ ⊢ e₁ ≡ e₂ : A) : Γ ⊢' e₁ ≡ e₂ : A := by
-  induction h with
-  | bvar h => exact .bvar h
-  | symm _ ih => exact .symm ih
-  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
-  | trans' h1 h2 ih1 ih2 => cases h1.uniq_sort h2; exact .trans ih1 ih2
-  | sort => exact .sort
-  | const h1 h2 => exact .const h1 h2
-  | appDF _ _ ih1 ih2 => exact .appDF ih1 ih2
-  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
-  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
-  | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
-  | beta _ _ ih1 ih2 => exact .beta ih1 ih2
-  | eta _ ih => exact .eta ih
-  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
-  | extra h1 h2 => exact .extra h1 h2
+variable [Params] [Params.Semantic]
 
-/-- `IsDefEq` and `IsDefEq'` are equivalent. -/
-theorem IsDefEq.iff_isDefEq' {Γ : List SExpr} {e₁ e₂ A : SExpr} :
-    Γ ⊢ e₁ ≡ e₂ : A ↔ Γ ⊢' e₁ ≡ e₂ : A :=
-  ⟨IsDefEq.toIsDefEq', IsDefEq'.toIsDefEq⟩
+/-- Compatibility spelling for semantic sort injectivity on the strong
+judgment.  Unlike the retired weak theorem, its premise retains every typing
+and local-extension certificate required by adequacy. -/
+theorem IsDefEqStrong.uniq_sort
+    (hΓ : Ctx.WF Γ)
+    (h : IsDefEqStrong Γ (.sort u) (.sort v) V) : u = v :=
+  SExpr.sort_inv hΓ h
 
 end SExpr
 end Lean4Lean
diff --git a/Lean4Lean/FuelConfig.lean b/Lean4Lean/FuelConfig.lean
index a1e633fe..32eb3966 100644
--- a/Lean4Lean/FuelConfig.lean
+++ b/Lean4Lean/FuelConfig.lean
@@ -9,11 +9,11 @@ Every field is a positive `Nat`; on exhaustion the corresponding loop throws
 `.deterministicTimeout` (whnf-family) or `.deepRecursion` (structural /
 mutual-recursion loops).
 
-Defaults are set so mathlib passes.  The C++ Lean kernel has no analog for any
-of these bounds (its whnf/lazy-delta loops are `while (true)` and its
-mutual-recursion depth is bounded only by the native stack); the counters exist
-in lean4lean purely as termination witnesses for the Lean-level proofs and as a
-defensive check against runaway reductions.
+Defaults are set so mathlib passes. Since lean4#13956 the native kernel bounds
+its mutually recursive type-checker entry points using `maxRecDepth`.
+Lean4lean instead keeps separate, explicit fuel for those calls and for loops
+that need structural termination witnesses; these counters also provide a
+deterministic defensive check against runaway reductions.
 -/
 structure FuelConfig where
   /-- `whnf'` unfold-loop, non-eager path (`TypeChecker.lean` whnf'). -/
diff --git a/Lean4Lean/Inductive/Add.lean b/Lean4Lean/Inductive/Add.lean
index b8f07377..4f057747 100644
--- a/Lean4Lean/Inductive/Add.lean
+++ b/Lean4Lean/Inductive/Add.lean
@@ -474,7 +474,7 @@ where
         if levelStructGe stats.resultLevel s.sortLevel! then
           pure ()
         else
-          unless stats.resultLevel.isZero || stats.resultLevel.geq s.sortLevel! do
+          unless stats.resultLevel.isAlwaysZero || stats.resultLevel.geq s.sortLevel! do
             throw <| .other s!"universe level of type_of(arg #{i + 1}) of '{n}' \
               is too big for the corresponding inductive datatype"
         if !isUnsafe then
@@ -504,12 +504,20 @@ def checkConstructorFold (env : Environment) (stats : InductiveStats)
     checkConstructorType stats isUnsafe idx n t
     checkConstructorFold env stats isUnsafe idx seen ctors
 
+/-- The named family recursion of `checkConstructors`.  Naming the loop keeps
+the executable shell and its validation-trace mirror aligned without depending
+on proof terms synthesized by `for` notation. -/
+def checkConstructorsLoop (env : Environment) (stats : InductiveStats)
+    (isUnsafe : Bool) : Nat → List InductiveType → M Unit
+  | _, [] => pure ()
+  | idx, indType :: rest => do
+    _ ← checkConstructorFold env stats isUnsafe idx {} indType.ctors
+    checkConstructorsLoop env stats isUnsafe (idx + 1) rest
+
 def checkConstructors (indTypes : Array InductiveType)
     (stats : InductiveStats) (isUnsafe : Bool) : M Unit := do
   let env ← getEnv
-  for h : idx in [:indTypes.size] do
-    let indType := indTypes[idx]
-    _ ← checkConstructorFold env stats isUnsafe idx {} indType.ctors
+  checkConstructorsLoop env stats isUnsafe 0 indTypes.toList
 
 /-- One observed WHNF node in the executable normalization-candidate pass.
 The complete `AddInductive.Context` is retained because Verify must replay the
@@ -1228,9 +1236,11 @@ theorem checkInductiveTypes_singleton_of_candidate
   rw [hterminal]
   simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply]
   rw [hensure]
-  simp only [Except.bind, Expr.sortLevel!]
-  simp only [InductiveStats.initial, Nat.zero_add]
-  rw [if_pos (by rfl : #[].isEmpty = true)]
+  simp only [Except.bind]
+  rw [if_pos (show ((InductiveStats.initial
+      (List.map Level.param context.lparams)).indConsts).isEmpty = true from
+    rfl)]
+  simp only [Expr.sortLevel!, InductiveStats.initial, Nat.zero_add]
   simp only [ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, Except.pure,
     Except.bind]
   rw [checkInductiveTypes.loopInd.eq_1]
@@ -1424,8 +1434,8 @@ where
         match observeCandidateWhnf context e with
         | .error err => throw err
         | .ok ⟨view, valid⟩ =>
-          match view with
-          | .forallE name domain body binderInfo =>
+          match view, valid with
+          | .forallE name domain body binderInfo, valid =>
             match hfresh : context.lctx.find? context.freshFVarId with
             | some _ =>
               throw (Exception.other
@@ -1443,7 +1453,7 @@ where
               return .forallE context e inferred name domain body
                 binderInfo hfresh annotations annotationsEq checked valid
                 domainCandidate bodyCandidate
-          | result =>
+          | result, valid =>
             return .terminal context e inferred result checked valid
 
 /-- One terminal recursive step of `buildCandidateExpr`, with its traversal
@@ -2449,7 +2459,7 @@ def isLargeEliminator (stats : InductiveStats) (indTypes : Array InductiveType)
         withLocalDecl name bi (consumeTypeAnnotations dom) fun arg => do
           let mut toCheck := toCheck
           if i ≥ stats.params.size then
-            if !(← ensureType dom).sortLevel!.isZero then
+            if !(← ensureType dom).sortLevel!.isAlwaysZero then
               toCheck := toCheck.push arg
           loop (body.instantiate1 arg) (i + 1) toCheck fuel
       else
@@ -2488,7 +2498,7 @@ def isKTargetCtor (nparams : Nat) : Nat → Expr → Bool
 
 def isKTarget (stats : InductiveStats) (indTypes : Array InductiveType) : M Bool := do
   let #[indType] := indTypes | return false
-  unless stats.resultLevel.isZero do return false
+  unless stats.resultLevel.isAlwaysZero do return false
   let [ctor] := indType.ctors | return false
   return isKTargetCtor stats.params.size 0 ctor.type
 
@@ -2926,9 +2936,21 @@ def mkAuxRecNameMap (env' : Environment) (types : List InductiveType) :
     oldRecNames := oldRecNames.push oldRecName
   return (oldRecNames.toList, recMap)
 
+def checkNoNestedAux (n : Name) (e : Expr) : Except Exception Unit := do
+  if (e.find? fun
+      | .const c _ => (`_nested).isPrefixOf c
+      | .proj s _ _ => (`_nested).isPrefixOf s
+      | _ => false).isSome then
+    throw <| .other s!"invalid declaration '{n}', it uses the reserved prefix '_nested'"
+
 def Environment.addInductive (env : Environment) (lparams : List Name) (nparams : Nat)
     (types : List InductiveType) (isUnsafe allowPrimitive : Bool) (fuel : FuelConfig := {}) :
     Except Exception Environment := do
+  for indType in types do
+    env.checkNoMVarNoFVar indType.name indType.type
+    for ctor in indType.ctors do
+      env.checkNoMVarNoFVar ctor.name ctor.type
+      checkNoNestedAux ctor.name ctor.type
   let res ← ElimNestedInductive.run fuel.inductiveFuel nparams types env
     |>.run' { lvls := lparams.map .param, newTypes := types.toArray }
   let numNested := res.aux2nested.size
diff --git a/Lean4Lean/Inductive/EliminationTrace.lean b/Lean4Lean/Inductive/EliminationTrace.lean
index d3e62547..b62cf3e5 100644
--- a/Lean4Lean/Inductive/EliminationTrace.lean
+++ b/Lean4Lean/Inductive/EliminationTrace.lean
@@ -32,7 +32,7 @@ inductive LargeEliminatorLoopTrace (stats : InductiveStats) :
       (ensureType : ConstructorEnsureTypeStep.Valid
         ⟨context.pushLocalDecl name binderInfo
           (consumeTypeAnnotations domain), domain, sortResult⟩)
-      (isProp : sortResult.sortLevel!.isZero = true)
+      (isProp : sortResult.sortLevel!.isAlwaysZero = true)
       (tail : LargeEliminatorLoopTrace stats
         (context.pushLocalDecl name binderInfo
           (consumeTypeAnnotations domain))
@@ -47,7 +47,7 @@ inductive LargeEliminatorLoopTrace (stats : InductiveStats) :
       (ensureType : ConstructorEnsureTypeStep.Valid
         ⟨context.pushLocalDecl name binderInfo
           (consumeTypeAnnotations domain), domain, sortResult⟩)
-      (isProp : sortResult.sortLevel!.isZero = false)
+      (isProp : sortResult.sortLevel!.isAlwaysZero = false)
       (tail : LargeEliminatorLoopTrace stats
         (context.pushLocalDecl name binderInfo
           (consumeTypeAnnotations domain))
@@ -162,7 +162,7 @@ def buildExecution (stats : InductiveStats) (context : Context)
                 (TypeChecker.ensureType domain) with
             | .error error => .error error
             | .ok sortResult =>
-                if isProp : sortResult.sortLevel!.isZero then
+                if isProp : sortResult.sortLevel!.isAlwaysZero then
                   match buildExecution stats nextContext nextSource
                       (argIdx + 1) toCheck fuel with
                   | .error error => .error error
@@ -178,7 +178,7 @@ def buildExecution (stats : InductiveStats) (context : Context)
                       .dataField context fuel argIdx toCheck name domain body
                         binderInfo sortResult (Nat.le_of_not_gt isParameter)
                         hensure (by
-                          cases h : sortResult.sortLevel!.isZero <;> simp_all)
+                          cases h : sortResult.sortLevel!.isAlwaysZero <;> simp_all)
                         tail⟩
         | _ => .error <| .other
             "large-eliminator source shape disagrees with isForall"
@@ -435,7 +435,7 @@ structure KTargetSingletonExecution
     (result : Bool) where
   indType : InductiveType
   indTypes_eq : indTypes = #[indType]
-  resultLevelZero : stats.resultLevel.isZero = true
+  resultLevelZero : stats.resultLevel.isAlwaysZero = true
   ctor : Constructor
   ctors_eq : indType.ctors = [ctor]
   trace : KTargetCtorTrace stats.params.size ctor.type 0 result
@@ -460,7 +460,7 @@ def buildExecution (stats : InductiveStats)
   | .ok result =>
       match _htypes : indTypes with
       | #[indType] =>
-          if hzero : stats.resultLevel.isZero then
+          if hzero : stats.resultLevel.isAlwaysZero then
             match hctors : indType.ctors with
             | [ctor] =>
                 let ⟨traceResult, trace⟩ :=
diff --git a/Lean4Lean/Inductive/Reduce.lean b/Lean4Lean/Inductive/Reduce.lean
index deb29292..cdac9f9e 100644
--- a/Lean4Lean/Inductive/Reduce.lean
+++ b/Lean4Lean/Inductive/Reduce.lean
@@ -20,6 +20,12 @@ def mkNullaryCtor (type : Expr) (nparams : Nat) : Option Expr :=
   let name ← getFirstCtor env dName
   return mkAppRange (.const name ls) 0 nparams args
 
+/-- When `e` has the type of a K-like inductive, converts it into a constructor application.
+
+For instance if we have `e : Eq a a`, it is converted into `Eq.refl a` (which it is definitionally
+equal to by proof irrelevance). Note that the indices of `e`'s type must match those of the
+constructor application (for instance, `e : Eq a b` cannot be converted if `a` and `b` are not
+defeq). -/
 def toCtorWhenK (rval : RecursorVal) (e : Expr) : m Expr := do
   assert! rval.k
   let appType ← whnf (← inferType e)
@@ -30,6 +36,7 @@ def toCtorWhenK (rval : RecursorVal) (e : Expr) : m Expr := do
     for h : i in [rval.numParams:appTypeArgs.size] do
       if appTypeArgs[i].hasExprMVar then return e
   let some newCtorApp := mkNullaryCtor env appType rval.numParams | return e
+  -- check that the indices of types of `e` and `newCtorApp` match
   unless ← isDefEq appType (← inferType newCtorApp) do return e
   return newCtorApp
 
@@ -43,6 +50,11 @@ def expandEtaStruct (eType e : Expr) : Expr :=
     result := .app result (.proj I i e)
   pure result
 
+/-- When `e` is of non-recursive structure type, and that type is not a proposition, converts `e`
+into a constructor application using projections.
+
+For instance if we have `e : α × β`, it is converted into `Prod.mk α β e.1 e.2` (which is
+definitionally equal to `e` by struct eta). -/
 def toCtorWhenStruct (inductName : Name) (e : Expr) : m Expr := do
   if !env.isNonRecStructure inductName || (e.isConstructorApp?' env).isSome then
     return e
@@ -56,6 +68,15 @@ def getRecRuleFor (rval : RecursorVal) (major : Expr) : Option RecursorRule := d
   let .const fn _ := major.getAppFn | none
   rval.rules.find? (·.ctor == fn)
 
+/-- Performs recursor reduction on `e` (returning `none` if not applicable).
+
+For recursor reduction to occur, `e` must be a recursor application where the major premise is
+either a complete constructor application, a `Nat` or `String` literal, or of a K- or
+structure-like inductive type (in each case it is converted into an equivalent constructor
+application). The reduction is done by applying the `RecursorRule.rhs` associated with the
+constructor to everything before the indices in the recursor application (its parameters, motives
+and minor premises) and then to the fields of the constructor application; any arguments after the
+major premise are re-applied to the result. -/
 def inductiveReduceRec [Monad m] (env : Environment) (e : Expr)
     (whnf : Expr → m Expr) (inferType : Expr → m Expr) (isDefEq : Expr → Expr → m Bool) :
     m (Option Expr) := do
@@ -76,7 +97,10 @@ def inductiveReduceRec [Monad m] (env : Environment) (e : Expr)
   if rule.nfields > majorArgs.size then return none
   if ls.length != info.levelParams.length then return none
   let mut rhs := rule.rhs.instantiateLevelParams info.levelParams ls
+  -- get the parameters, motives and minor premises from the recursor application (recursor rules
+  -- don't need the indices, as these are determined by the constructor and its parameters/fields)
   rhs := mkAppRange rhs 0 info.getFirstIndexIdx recArgs
+  -- get fields from constructor application
   rhs := mkAppRange rhs (majorArgs.size - rule.nfields) majorArgs.size majorArgs
   if majorIdx + 1 < recArgs.size then
     rhs := mkAppRange rhs (majorIdx + 1) recArgs.size recArgs
diff --git a/Lean4Lean/Inductive/ValidationTrace.lean b/Lean4Lean/Inductive/ValidationTrace.lean
index 314c604a..d33182d8 100644
--- a/Lean4Lean/Inductive/ValidationTrace.lean
+++ b/Lean4Lean/Inductive/ValidationTrace.lean
@@ -38,7 +38,7 @@ inductive ConstructorUniverseTrace (resultLevel fieldLevel : Level) : Type where
       ConstructorUniverseTrace resultLevel fieldLevel
   | fallback
       (structuralFailed : levelStructGe resultLevel fieldLevel = false)
-      (valid : (resultLevel.isZero || resultLevel.geq fieldLevel) = true) :
+      (valid : (resultLevel.isAlwaysZero || resultLevel.geq fieldLevel) = true) :
       ConstructorUniverseTrace resultLevel fieldLevel
 
 namespace ConstructorUniverseTrace
@@ -48,7 +48,7 @@ successful universe trace. -/
 theorem not_nonempty_of_rejected
     (structuralRejected : levelStructGe resultLevel fieldLevel = false)
     (fallbackRejected :
-      (resultLevel.isZero || resultLevel.geq fieldLevel) = false) :
+      (resultLevel.isAlwaysZero || resultLevel.geq fieldLevel) = false) :
     ¬ Nonempty (ConstructorUniverseTrace resultLevel fieldLevel) := by
   rintro ⟨trace⟩
   cases trace with
@@ -244,6 +244,62 @@ def buildExecution (stats : InductiveStats) (ctor : Name) (argIdx : Nat)
                   | some targetIdx => .ok (.target context source result fuel
                       targetIdx hwhnf hoccurs hforall hvalid)
 
+/-- The transparent decomposition succeeds on every input accepted by the
+executable positivity traversal, so retained-trace construction needs no
+choice principle. -/
+theorem buildExecution_ok_of_run
+    (success : checkPositivity.loop stats ctor argIdx source fuel context =
+      .ok ()) :
+    ∃ trace, buildExecution stats ctor argIdx context source fuel =
+      .ok trace := by
+  induction fuel generalizing context source with
+  | zero =>
+      rw [checkPositivity.loop.eq_1] at success
+      change Except.error Exception.deepRecursion = Except.ok () at success
+      contradiction
+  | succ fuel ih =>
+      rw [checkPositivity.loop.eq_2] at success
+      simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success
+      unfold buildExecution
+      split
+      next error heq =>
+        rw [heq] at success
+        simp [Except.bind] at success
+      next result heq =>
+        rw [heq] at success
+        simp only [Except.bind] at success
+        split
+        next hoccurs => exact ⟨_, rfl⟩
+        next hoccurs =>
+          rw [hoccurs] at success
+          simp only [Bool.not_true, Bool.false_eq_true, if_false,
+            ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
+            Except.bind, Except.pure] at success
+          cases result <;> simp only [Expr.isForall] <;> simp only at success
+          case forallE name domain body binderInfo =>
+            split
+            next hdomain =>
+              rw [hdomain] at success
+              change Except.error _ = Except.ok () at success
+              contradiction
+            next hdomain =>
+              rw [hdomain] at success
+              have tailSuccess :
+                  checkPositivity.loop stats ctor argIdx
+                    (body.instantiate1 context.freshExpr) fuel
+                    (context.pushLocalDecl name binderInfo
+                      (consumeTypeAnnotations domain)) = .ok () := success
+              obtain ⟨tail, htail⟩ := ih tailSuccess
+              rw [htail]
+              exact ⟨_, rfl⟩
+          all_goals
+            split
+            next hvalid =>
+              rw [hvalid] at success
+              change Except.error _ = Except.ok () at success
+              contradiction
+            next targetIdx hvalid => exact ⟨_, rfl⟩
+
 /-- An exact positivity failure, including its diagnostic payload, excludes a
 successful trace at precisely that source/context/fuel position. -/
 theorem not_nonempty_of_error
@@ -353,6 +409,28 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool)
       | .error error => .error error
       | .ok trace => .ok (.safe rfl trace)
 
+/-- The retained safe/unsafe branch decomposition succeeds whenever the
+executable positivity branch does. -/
+theorem buildExecution_ok_of_run
+    (success :
+      (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ())
+        context = .ok ()) :
+    ∃ trace, buildExecution stats isUnsafe ctor argIdx context source =
+      .ok trace := by
+  cases isUnsafe with
+  | true => exact ⟨_, rfl⟩
+  | false =>
+      simp only [Bool.not_false, if_true] at success
+      unfold checkPositivity at success
+      simp only [readThe, MonadReaderOf.read, ReaderT.read,
+        ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
+        Except.bind, Except.pure] at success
+      obtain ⟨trace, htrace⟩ :=
+        ConstructorPositivityTrace.buildExecution_ok_of_run success
+      unfold buildExecution
+      rw [htrace]
+      exact ⟨_, rfl⟩
+
 /-- Failure of the exact safe/unsafe positivity branch excludes its retained
 mode trace without changing the executable diagnostic. -/
 theorem not_nonempty_of_error
@@ -600,7 +678,7 @@ theorem exists_of_run
                     rw [hstruct] at success
                     simp only [Bool.false_eq_true, if_false] at success
                     cases hfallback :
-                        (stats.resultLevel.isZero ||
+                        (stats.resultLevel.isAlwaysZero ||
                           stats.resultLevel.geq sortResult.sortLevel!) with
                     | false =>
                         rw [hfallback] at success
@@ -688,7 +766,7 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool)
                           sortResult.sortLevel! with
                       | true => finish (.structural hstruct)
                       | false =>
-                          match hfallback : stats.resultLevel.isZero ||
+                          match hfallback : stats.resultLevel.isAlwaysZero ||
                               stats.resultLevel.geq sortResult.sortLevel! with
                           | false => .error <| .other
                               s!"universe level of type_of(arg #{argIdx + 1}) of '{ctor}' is too big for the corresponding inductive datatype"
@@ -696,6 +774,149 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool)
           | _ => .error <| .other
               "constructor source shape disagrees with isForall"
 
+/-- The transparent telescope decomposition succeeds on every constructor
+type accepted by the inner executable validator. -/
+theorem buildExecution_ok_of_run
+    (success :
+      checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel
+        context = .ok ()) :
+    ∃ trace, buildExecution stats isUnsafe familyIdx ctor context source
+      argIdx fuel = .ok trace := by
+  induction fuel generalizing context source argIdx with
+  | zero =>
+      rw [checkConstructorType.loop.eq_1] at success
+      change Except.error Exception.deepRecursion = Except.ok () at success
+      contradiction
+  | succ fuel ih =>
+      rw [show fuel + 1 = Nat.succ fuel by omega] at success
+      cases source
+      case forallE name domain body binderInfo =>
+        rw [checkConstructorType.loop.eq_2] at success
+        simp only at success
+        unfold buildExecution
+        simp only [Expr.isForall]
+        split
+        next param hparam =>
+          rw [hparam] at success
+          simp only [ReaderT.bind, Bind.bind] at success
+          split
+          next error heq =>
+            rw [heq] at success
+            simp [Except.bind] at success
+          next parameterType heq =>
+            rw [heq] at success
+            simp only [Except.bind, liftTypeChecker_apply] at success
+            split
+            next error heq2 =>
+              rw [heq2] at success
+              simp [Except.bind] at success
+            next heq2 =>
+              rw [heq2] at success
+              simp only [Except.bind] at success
+              change Except.error _ = Except.ok () at success
+              contradiction
+            next heq2 =>
+              rw [heq2] at success
+              simp only [Except.bind, if_true, ReaderT.pure, Pure.pure,
+                ReaderT.bind, Bind.bind, Except.pure] at success
+              obtain ⟨tail, htail⟩ := ih success
+              rw [htail]
+              exact ⟨_, rfl⟩
+        next hparam =>
+          rw [hparam] at success
+          simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success
+          split
+          next error heq =>
+            rw [heq] at success
+            simp [Except.bind] at success
+          next sortResult heq =>
+            rw [heq] at success
+            simp only [Except.bind] at success
+            have finish :
+                (do
+                  if !isUnsafe then checkPositivity stats domain ctor argIdx
+                  withLocalDecl name binderInfo (consumeTypeAnnotations domain)
+                      fun arg =>
+                    checkConstructorType.loop stats isUnsafe familyIdx ctor
+                      (body.instantiate1 arg) (argIdx + 1) fuel)
+                    context = .ok () →
+                (∃ positivity,
+                  ConstructorPositivityModeTrace.buildExecution stats isUnsafe
+                    ctor argIdx context domain = .ok positivity) ∧
+                ∃ tail,
+                  buildExecution stats isUnsafe familyIdx ctor
+                    (context.pushLocalDecl name binderInfo
+                      (consumeTypeAnnotations domain))
+                    (body.instantiate1 context.freshExpr) (argIdx + 1) fuel =
+                    .ok tail := by
+              intro restSuccess
+              cases isUnsafe with
+              | false =>
+                  simp only [Bool.not_false, if_true,
+                    ReaderT.bind, Bind.bind] at restSuccess
+                  cases hpos : checkPositivity stats domain ctor argIdx
+                      context with
+                  | error err => simp_all [Except.bind]
+                  | ok posUnit =>
+                      cases posUnit
+                      rw [hpos] at restSuccess
+                      simp only [Except.bind,
+                        withLocalDecl_apply] at restSuccess
+                      have hpmSuccess :
+                          (if !false then
+                            checkPositivity stats domain ctor argIdx
+                          else pure ()) context = .ok () := by
+                        simpa using hpos
+                      exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run
+                        hpmSuccess, ih restSuccess⟩
+              | true =>
+                  simp only [Bool.not_true, if_false,
+                    ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
+                    Except.bind, Except.pure,
+                    withLocalDecl_apply] at restSuccess
+                  have hpmSuccess :
+                      (if !true then
+                        checkPositivity stats domain ctor argIdx
+                      else pure ()) context = .ok () := by
+                    simp [ReaderT.pure, Pure.pure, Except.pure]
+                  exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run
+                    hpmSuccess, ih restSuccess⟩
+            split
+            next hstruct =>
+              rw [hstruct] at success
+              simp only [if_true, ReaderT.pure, Pure.pure,
+                ReaderT.bind, Bind.bind, Except.bind, Except.pure] at success
+              obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success
+              rw [hpm, htail]
+              exact ⟨_, rfl⟩
+            next hstruct =>
+              rw [hstruct] at success
+              simp only [Bool.false_eq_true, if_false] at success
+              split
+              next hfallback =>
+                rw [hfallback] at success
+                change Except.error _ = Except.ok () at success
+                contradiction
+              next hfallback =>
+                rw [hfallback] at success
+                simp only [Bool.true_eq_false, Bool.not_true, if_false,
+                  ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
+                  Except.bind, Except.pure] at success
+                obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success
+                rw [hpm, htail]
+                exact ⟨_, rfl⟩
+      all_goals
+        unfold checkConstructorType.loop at success
+        simp only at success
+        unfold buildExecution
+        simp only [Expr.isForall]
+        split
+        next hvalid =>
+          rw [hvalid] at success
+          change Except.error _ = Except.ok () at success
+          contradiction
+        next hvalid => exact ⟨_, rfl⟩
+
 /-- Erasing the inner trace also replays the public one-constructor checker,
 including its exact context-fuel read. -/
 theorem check_run
@@ -823,17 +1044,11 @@ theorem checkConstructors_singleton_eq_checkConstructorList
           context.lparams context.fuel TypeChecker.getEnv =
         .ok context.env := by rfl
   rw [hget]
-  simp only [Except.bind,
-    Std.Legacy.Range.forIn'_eq_forIn'_range', Std.Legacy.Range.size,
-    List.range', List.forIn'_cons, List.forIn'_nil,
-    List.size_toArray, List.length_cons, List.length_nil,
-    List.getElem_toArray, List.getElem_cons_zero,
-    Nat.sub_zero, Nat.zero_add, Nat.add_sub_cancel, Nat.div_one]
+  simp only [Except.bind]
+  simp only [checkConstructorsLoop]
   unfold checkConstructorList
   simp only [ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
     Except.bind, Except.pure]
-  cases checkConstructorFold context.env stats isUnsafe 0 {} indType.ctors context <;>
-    rfl
 
 namespace ConstructorListValidationTrace
 
@@ -1026,6 +1241,71 @@ theorem exists_of_fold_run
                       exact ⟨.cons seen head tail hfresh hclosed rootCheck
                         typeTrace tailTrace⟩
 
+/-- The transparent list decomposition succeeds on every constructor list
+accepted by the executable stateful fold. -/
+theorem buildExecution_ok_of_fold_run
+    (success : checkConstructorFold context.env stats isUnsafe familyIdx
+      seen ctors context = .ok result) :
+    ∃ trace, buildExecution stats isUnsafe familyIdx context seen ctors =
+      .ok trace := by
+  induction ctors generalizing seen result with
+  | nil => exact ⟨_, rfl⟩
+  | cons head tail ih =>
+      unfold checkConstructorFold at success
+      simp only at success
+      unfold buildExecution
+      split
+      next hfresh =>
+        rw [hfresh] at success
+        change Except.error _ = Except.ok result at success
+        contradiction
+      next hfresh =>
+        rw [hfresh] at success
+        simp only [Bool.false_eq_true, if_false,
+          ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
+          Except.bind, Except.pure] at success
+        split
+        next error heq =>
+          rw [heq] at success
+          simp [liftExcept_apply, Except.bind] at success
+        next heq =>
+          rw [heq] at success
+          simp only [liftExcept_apply, Except.bind] at success
+          rw [withEmptyLocalContext_apply, liftTypeChecker_apply] at success
+          split
+          next error heq2 =>
+            rw [heq2] at success
+            simp [Except.bind] at success
+          next inferred heq2 =>
+            rw [heq2] at success
+            simp only [Except.bind] at success
+            cases htype : checkConstructorType stats isUnsafe familyIdx
+                head.name head.type context with
+            | error err => simp_all [Except.bind]
+            | ok typeResult =>
+                cases typeResult
+                rw [htype] at success
+                simp only [Except.bind, ReaderT.pure, Pure.pure,
+                  Except.pure] at success
+                have htypeLoop :
+                    checkConstructorType.loop stats isUnsafe familyIdx
+                        head.name head.type 0 context.fuel.inductiveFuel
+                        context = .ok () := by
+                  unfold checkConstructorType at htype
+                  simpa only [readThe, MonadReaderOf.read, ReaderT.read,
+                    ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
+                    Except.bind, Except.pure] using htype
+                obtain ⟨typeTrace, hT⟩ :=
+                  ConstructorTypeValidationTrace.buildExecution_ok_of_run
+                    htypeLoop
+                rw [hT]
+                change checkConstructorFold context.env stats isUnsafe
+                  familyIdx (seen.insert head.name) tail context =
+                    .ok result at success
+                obtain ⟨tailTrace, htl⟩ := ih success
+                rw [htl]
+                exact ⟨_, rfl⟩
+
 /-- The stateful list fold's exact error value excludes a complete trace for
 that same source list and incoming duplicate-name accumulator. -/
 theorem not_nonempty_of_fold_error
@@ -1219,6 +1499,24 @@ def buildExecution (indType : InductiveType) (stats : InductiveStats)
   | .error error => .error error
   | .ok trace => .ok ⟨trace⟩
 
+/-- The transparent singleton decomposition succeeds on every source family
+accepted by the real constructor validator. -/
+theorem buildExecution_ok_of_run
+    (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) :
+    ∃ validation, buildExecution indType stats isUnsafe context =
+      .ok validation := by
+  rw [checkConstructors_singleton_eq_checkConstructorList] at success
+  unfold checkConstructorList at success
+  cases hfold : checkConstructorFold context.env stats isUnsafe 0 {}
+      indType.ctors context with
+  | error err => simp_all [Functor.map, Except.map]
+  | ok result =>
+      obtain ⟨trace, htrace⟩ :=
+        ConstructorListValidationTrace.buildExecution_ok_of_fold_run hfold
+      unfold buildExecution
+      rw [htrace]
+      exact ⟨_, rfl⟩
+
 /-- Recomposition: retained operational evidence replays the real singleton
 `checkConstructors` execution exactly. -/
 theorem run
@@ -1243,13 +1541,16 @@ theorem nonempty_of_run
         ConstructorListValidationTrace.exists_of_fold_run hfold
       exact ⟨⟨trace⟩⟩
 
-/-- Choose the unique-by-source operational shape supplied by a successful
-run. The only nonconstructive ingredient is the project's existing baseline
-`Classical.choice`; every retained equality comes from the executable run. -/
-noncomputable def of_run
+/-- Choose the operational shape supplied by a successful run by replaying
+the transparent decomposition.  The success premise only discharges the
+impossible error branch, so the retained evidence is computed by
+`buildExecution` rather than selected through `Classical.choice`. -/
+def of_run
     (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) :
     ConstructorValidationRun indType stats isUnsafe context :=
-  Classical.choice (nonempty_of_run success)
+  match h : buildExecution indType stats isUnsafe context with
+  | .ok validation => validation
+  | .error _ => absurd (buildExecution_ok_of_run success) (by simp [h])
 
 /-- Exact decomposition/recomposition contract for singleton constructor
 validation. -/
diff --git a/Lean4Lean/Instantiate.lean b/Lean4Lean/Instantiate.lean
index b8cd6b9b..e5379536 100644
--- a/Lean4Lean/Instantiate.lean
+++ b/Lean4Lean/Instantiate.lean
@@ -5,6 +5,10 @@ import Lean.Util.InstantiateLevelParams
 namespace Lean
 namespace Expr
 
+/-- Beta-reduces an application `(fun x₁ ... xₙ => b) a₁ ... aₙ aₙ₊₁ ... aₘ` in the two cases where
+no substitution is needed: to `b aₙ₊₁ ... aₘ` when `b` has no loose bound variables, and to
+`aᵢ aₙ₊₁ ... aₘ` when `b` is the bound variable `xᵢ`. In any other case `e` is returned unchanged —
+this is what makes it cheap. -/
 def cheapBetaReduce (e : Expr) : Expr := Id.run do
   if !e.isApp then return e
   let fn := e.getAppFn
diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean
index 59c8777b..1aef093a 100644
--- a/Lean4Lean/Level.lean
+++ b/Lean4Lean/Level.lean
@@ -10,6 +10,7 @@ def forEach [Monad m] (l : Level) (f : Level → m Bool) : m Unit := do
   | .max l₁ l₂ | .imax l₁ l₂ => l₁.forEach f; l₂.forEach f
   | .zero | .param .. | .mvar .. => pure ()
 
+/-- Returns `some n` if level parameter `n` appears in `l` and `n ∉ ps`. -/
 def getUndefParam (l : Level) (ps : List Name) : Option Name := Id.run do
   (·.2) <$> StateT.run (s := none) do
     l.forEach fun l => do
@@ -37,13 +38,10 @@ structure VarNode where
   offset : Nat
   deriving BEq, Ord, Repr
 
-/-- An key-value pair `vs => { path, const, var }` in NormLevel represents
+/-- A key-value pair `vs => { const, var }` in NormLevel represents
 the max of `C(vs, const)` and `V(vs, v, n)` for each `v+n ∈ var`, using the `C` and `V` sublevel
-functions from <https://lmf.cnrs.fr/downloads/Perso/long.pdf>.
-The `path` assists in ensuring the invariant that for each suffix `vs' <:+ path`,
-`vs'` is also in the `NormLevel` map. -/
+functions from <https://lmf.cnrs.fr/downloads/Perso/long.pdf>. -/
 structure Node where
-  path : List Name := []
   const : Nat := 0
   var : List VarNode := []
   deriving Repr, Inhabited
@@ -53,6 +51,8 @@ instance : BEq Node where
 instance : Ord Node where
   compare n₁ n₂ := compare n₁.const n₂.const |>.then <| compare n₁.var n₂.var
 
+def Node.isEmpty (n : Node) : Bool := n.const == 0 && n.var.isEmpty
+
 def subset (cmp : α → α → Ordering) : List α → List α → Bool
   | [], _ => true
   | _, [] => false
@@ -70,11 +70,13 @@ def orderedInsert (cmp : α → α → Ordering) (a : α) : List α → Option (
     | .eq => none
     | .gt => (orderedInsert cmp a l).map (b :: ·)
 
-def NormLevel := Std.TreeMap (List Name) Node compare
+@[reducible] def NormLevel := Std.TreeMap (List Name) Node compare
   deriving Repr
 
 instance : BEq NormLevel where
-  beq l₁ l₂ := l₁.toList == l₂.toList
+  beq l₁ l₂ :=
+    (l₁.all fun p n => l₂.get? p == some n) &&
+    (l₂.all fun p n => l₁.get? p == some n)
 
 def VarNode.addVar (v : Name) (k : Nat) : List VarNode → List VarNode
   | [] => [⟨v, k⟩]
@@ -94,7 +96,9 @@ def NormLevel.addNode (v : Name) (k : Nat) (path' : List Name) (s : NormLevel) :
 
 def NormLevel.addConst (k : Nat) (path : List Name) (acc : NormLevel) : NormLevel :=
   if k = 0 || k = 1 && !path.isEmpty then acc else
-  acc.modify path fun n => { n with const := k.max n.const }
+  acc.alter path fun
+    | none => some { const := k }
+    | some n => some { n with const := k.max n.const }
 
 def normalizeAux (l : Level) (path : List Name) (k : Nat) (acc : NormLevel) : NormLevel :=
   match l with
@@ -125,78 +129,110 @@ def subsumeVars : List VarNode → List VarNode → List VarNode
     | .eq => if x.offset ≤ y.offset then subsumeVars xs ys else x :: subsumeVars xs ys
     | .gt => subsumeVars (x :: xs) ys
 
-def findParent (f : List Name → Bool) : (l₁ l₂ : List Name) → List Name
-  | _, [] => []
-  | l₁, a :: l₂ => if f (l₁.reverseAux l₂) then [a] else findParent f (a :: l₁) l₂
-
-/-- Whether `n₁.const` is semantically dominated while comparing the node at
-`p₁` with the node at `p₂`.  The path-membership witnesses make the test sound
-for every `NormLevel`, not only maps produced by `normalizeAux`: a variable in
-an active path evaluates to at least one. -/
-abbrev Node.constIsSubsumedBy (n₁ : Node) (p₁ p₂ : List Name) (n₂ : Node) : Prop :=
-  (p₁.length ≠ p₂.length ∧ n₁.const ≤ n₂.const) ∨
-  (n₂.var ≠ [] ∧ ∃ v ∈ n₁.var, v.var ∈ p₁ ∧ n₁.const ≤ v.offset + 1) ∨
-  (p₁.length ≠ p₂.length ∧ n₁.const ≤ 1 ∧ ∃ v ∈ n₂.var, v.var ∈ p₂)
-
-def Node.subsumptionStep (n₁ : Node) (p₁ p₂ : List Name) (n₂ : Node) : Node :=
-  if !subset compare p₂ p₁ then n₁ else
-  let same := p₁.length == p₂.length
-  let n₁ := if n₁.const = 0 ∨ ¬n₁.constIsSubsumedBy p₁ p₂ n₂ then
-    n₁
-  else
-    { n₁ with const := 0 }
+/-- Remove from `n₁` the sublevels dominated by `n₂`, whose condition set is a subset of
+`n₁`'s: `C(c)` is dominated by `C(c')` when `c ≤ c'` and by `V(x+k)` when `c ≤ k + 1`, and
+`V(x+k)` is dominated by `V(x+k')` when `k ≤ k'`.
+
+`same` says the two sit at the *same* condition set, where a variable may still discharge the
+constant but the variables must not discharge themselves. -/
+def Node.subsumeBy (same : Bool) (n₁ n₂ : Node) : Node :=
+  let n₁ :=
+    if n₁.const = 0 ||
+      (same || n₁.const > n₂.const) &&
+      (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1)
+    then n₁ else { n₁ with const := 0 }
   if same || n₂.var.isEmpty then n₁ else { n₁ with var := subsumeVars n₁.var n₂.var }
 
-def NormLevel.subsumption (acc : NormLevel) (paths := false) : NormLevel :=
-  acc.foldl (init := acc) fun acc p₁ n₁ =>
-    let n₁ := acc.foldl (init := n₁) fun n₁ p₂ n₂ => n₁.subsumptionStep p₁ p₂ n₂
-    let n₁ := if paths then
-      let path := findParent acc.contains [] p₁
-      let var := if let [v] := path then subsumeVars n₁.var [⟨v, 0⟩] else n₁.var
-      { n₁ with path, var }
-    else n₁
-    acc.insert p₁ n₁
-
-def normalize (l : Level) (paths := false) : NormLevel :=
-  Normalize.normalizeAux l [] 0 (.insert {} [] default) |>.subsumption paths
-
-def leVars : List VarNode → List VarNode → Bool
-  | [], _ => true
-  | _, [] => false
-  | x :: xs, y :: ys =>
-    match Name.cmp x.var y.var with
-    | .lt => false
-    | .eq => x.offset ≤ y.offset && leVars xs ys
-    | .gt => leVars (x :: xs) ys
+/-- Remove the parts of the sublevels at `(p₁, n₁)` that are dominated by the sublevels
+at `(p₂, n₂)`. -/
+def Node.subsume (p₁ : List Name) (n₁ : Node) (p₂ : List Name) (n₂ : Node) : Node :=
+  if subset compare p₂ p₁ then n₁.subsumeBy (p₁.length == p₂.length) n₂ else n₁
+
+/-- Remove the parts of the sublevels at `(p₁, n₁)` dominated by other entries of the map. -/
+def NormLevel.minimize (acc : NormLevel) (p₁ : List Name) (n₁ : Node) : Node :=
+  acc.foldl (init := n₁) (Node.subsume p₁)
 
+def NormLevel.subsumption (acc : NormLevel) : NormLevel :=
+  acc.foldl (init := acc) fun acc p₁ n₁ =>
+    let n := acc.minimize p₁ n₁
+    if n.isEmpty then acc.erase p₁ else acc.insert p₁ n
+
+def normalize (l : Level) : NormLevel :=
+  Normalize.normalizeAux l [] 0 {} |>.subsumption
+
+/-- Sublevel comparison, following Theorem 39 of the paper: `l₁ ≤ l₂` iff every sublevel
+of `l₁` is dominated by some sublevel of `l₂`, where
+`C(E, L) ≤ C(F, K) ↔ F ⊆ E ∧ L ≤ K`, `C(E, L) ≤ V(F, x, K) ↔ F ⊆ E ∧ L ≤ K + 1`,
+and `V(E, x, L) ≤ V(F, y, K) ↔ F ⊆ E ∧ x = y ∧ L ≤ K`.
+
+Each sublevel picks its own dominator, and a node bundles several of them, so it is not
+enough to look for a single entry of `l₂` dominating a whole node of `l₁`: for
+`imax 2 v ≤ max 2 v` the constant is dominated at `∅` and the variable at `{v}`. Instead
+each entry of `l₂` discharges what it can from the sublevels of `n₁` that are still
+outstanding, which is the same `subsumeBy` step minimization uses; the node is dominated
+once nothing is left, and the fold stops there. -/
 def NormLevel.le (l₁ l₂ : NormLevel) : Bool :=
-  l₁.toList.all fun (p₁, n₁) =>
-    if n₁.const = 0 && n₁.var.isEmpty then true else
-    l₂.toList.any fun (p₂, n₂) =>
-      (!n₂.var.isEmpty || n₁.var.isEmpty) &&
-      subset compare p₂ p₁ &&
-      (n₁.const ≤ n₂.const ||
-        n₂.var.any fun v => p₂.contains v.var && n₁.const ≤ v.offset + 1) &&
-      leVars n₁.var n₂.var
-
-def NormLevel.buildPaths : StateM NormLevel Unit := do
-  (← get).foldlM (init := ()) fun _ p _ => do
-    let n := (← get).get! p
-    if let [v] := n.path then
-      let l ← getPath (p.erase v) p.length
-      setPath p (v :: l)
+  l₁.all fun p₁ n₁ =>
+    -- `none` means nothing is left to discharge, which stops the fold
+    Option.isNone <| l₂.foldlM (init := n₁) (m := Option) fun n p₂ n₂ =>
+      if subset compare p₂ p₁ then
+        let n := n.subsumeBy false n₂
+        if n.isEmpty then none else some n
+      else some n
+
+/-!
+Reconstruction of a `Level` from a `NormLevel`.
+
+The paper's canonical form is a set of sublevels `C(S, k)`, `V(S, v+k)`; it does not address
+which such sets are expressible as level expressions. Reifying a sublevel with conditions `S`
+requires nesting it under an imax chain `imax (… imax (imax (_) v₁) …) vₙ` where
+`{v₁, …, vₙ} = S`, and each edge of such a chain itself contributes the sublevel
+`V(S', vᵢ, 0)` where `S'` is the set of conditions up to that point. So a chain order is
+admissible only if each such edge contribution is dominated by the canonical form, i.e.
+there is some `V(T, vᵢ+k)` with `T ⊆ S'` among the sublevels. Canonical forms produced by
+`normalizeAux` always admit at least one such order for every key
+(each key is the condition set of some `imax` chain suffix of the input, whose edges put
+the required `V` entries at subsets of the key, and subsumption only moves coverage to
+smaller sets).
+
+To make the output canonical, the choice of chain must depend only on the canonical
+sublevels, not on incidental map keys (which record which `imax` chains appeared
+syntactically in the input). For each key we take the lexicographically least admissible
+chain, computed greedily. This is well-defined: domination of `V(S', v, 0)` is monotone
+in `S'`, so extending the set of conditions added so far never invalidates other elements,
+and a greedy choice never needs to be revisited (checking that the remainder stays
+completable before committing to each element). -/
+
+/-- Is the edge contribution `V(acc ∪ {a}, a, 0)` dominated by the normal form?
+True iff some `V(T, a+k)` with `T ⊆ acc ∪ {a}` is present. -/
+def NormLevel.addable (s : NormLevel) (a : Name) (acc : List Name) : Bool :=
+  s.any fun p n => n.var.any (·.var == a) && subset compare (p.erase a) acc
+
+/-- Can the elements of `rem` be added to the condition set `acc` one at a time, each
+addition being `addable` at that point? Since `addable` is monotone in `acc`, adding any
+addable element preserves completability, so a greedy check is complete. -/
+def NormLevel.feasible (s : NormLevel) (acc rem : List Name) : Bool :=
+  go rem.length acc rem
 where
-  setPath (p path : List Name) : StateM NormLevel Unit :=
-    modify (·.modify p ({ · with path }))
-
-  getPath (p : List Name) (depth : Nat) : StateM NormLevel (List Name) := do
-    let n := (← get).get! p
-    if let [v] := n.path then
-      if let depth + 1 := depth then
-        let l ← getPath (p.erase v) depth
-        setPath p (v :: l)
-        return v :: l
-    return n.path
+  go : Nat → List Name → List Name → Bool
+  | 0, _, rem => rem.isEmpty
+  | fuel+1, acc, rem =>
+    match rem.find? (s.addable · acc) with
+    | none => rem.isEmpty
+    | some a => go fuel ((orderedInsert Name.cmp a acc).getD acc) (rem.erase a)
+
+/-- The lexicographically least admissible imax chain building the condition set `p`,
+listed innermost (last-added) first: at each step, remove the least element that is
+`addable` on top of the rest and whose remainder is still completable.
+This depends only on the sublevels of `s`, not on its key set, so equal normal forms
+reify to equal levels. (The fallback returns the remaining set in sorted order;
+it is not reachable for normal forms produced by `normalizeAux`.) -/
+def NormLevel.lexChain (s : NormLevel) : Nat → List Name → List Name
+  | 0, p => p
+  | fuel+1, p =>
+    match p.find? fun a => s.addable a (p.erase a) && s.feasible [] (p.erase a) with
+    | some a => a :: s.lexChain fuel (p.erase a)
+    | none => p
 
 structure Tree where
   const : Nat
@@ -218,39 +254,99 @@ def Tree.modify (path : List Name) (f : Tree → Tree) (t : Tree) : Tree :=
   | a :: p => modify p (t := t) fun t => { t with child := modifyAt f a t.child }
 
 def NormLevel.toTree (acc : NormLevel) : Tree :=
-  (buildPaths.run acc).run.2.foldl (init := ⟨0, [], []⟩) fun t _ n =>
-    t.modify n.path fun t => { t with const := n.const, var := n.var }
-
-def treeVarDedup : List VarNode → List (Name × Tree) → List VarNode
-  | [], _ => []
-  | xs, [] => xs
-  | x :: xs, y :: ys =>
-    match Name.cmp x.1 y.1 with
-    | .lt => x :: treeVarDedup xs (y :: ys)
-    | .eq => if x.2 = 0 then treeVarDedup xs ys else x :: treeVarDedup xs ys
-    | .gt => treeVarDedup (x :: xs) ys
+  acc.foldl (init := ⟨0, [], []⟩) fun t p n =>
+    let path := acc.lexChain p.length p
+    -- the edge into this tree node already contributes `V(p, v, 0)` for the innermost
+    -- chain element `v`, so an explicit `v+0` entry would be redundant
+    let var := if let v :: _ := path then subsumeVars n.var [⟨v, 0⟩] else n.var
+    t.modify path fun t => { t with const := n.const, var }
+
+/-- If the subtree behind an edge labelled `a` holds nothing but the sublevel `V(_, a, k)`,
+return `k`.
+
+Such an edge contributes `imax (a+k) a`, which differs from the plain `a+k` only at `a = 0`,
+where the plain form gives `k` instead of `0`. So the guard may be dropped, and the child
+written as just `a+k`, whenever the node's constant is at least `k` — and if the constant is
+*exactly* `k`, it may then be dropped itself, since `a+k ≥ k`. Without this, `u+1` would reify
+to `max 1 (imax (u+1) u)` rather than to itself, and the canonical form would be roughly twice
+the size of the input on typical levels. -/
+def Tree.plainOffset? (a : Name) : Tree → Option Nat
+  | ⟨0, [], []⟩ => some 0
+  | ⟨0, [v], []⟩ => if v.var == a then some v.offset else none
+  | _ => none
 
 def Tree.reify : Tree → Level
   | { const, var, child } =>
-    let l := child.foldr mkChild none
-    let l := (treeVarDedup var child).foldr (init := l) fun n r =>
+    let l := child.foldr (mkChild const) none
+    let l := var.foldr (init := l) fun n r =>
       some (mkMax (addOffset (.param n.var) n.offset) r)
     match l with
     | none => ofNat const
-    | some l => if const = 0 then l else max (ofNat const) l
+    | some l =>
+      if const == 0 || child.any fun c => plainOffset? c.1 c.2 == some const then l
+      else max (ofNat const) l
 where
   mkMax (l : Level) : Option Level → Level
   | none => l
   | some u => max l u
-  mkChild
+  mkChild (const : Nat)
   | (n, t), r =>
-    match reify t with
-    | .zero => mkMax (.param n) r
-    | t => mkMax (imax t (.param n)) r
+    match plainOffset? n t with
+    | some k =>
+      if k ≤ const then mkMax (addOffset (.param n) k) r
+      else mkMax (imax (reify t) (.param n)) r
+    | none => mkMax (imax (reify t) (.param n)) r
+
+/-!
+### Fast path for levels without an essential `imax`
+
+Levels arising in practice are almost always built from `zero`, `succ`, `max` and `param`
+alone: `mkLevelIMax'` already discharges `imax _ 0`, `imax _ (_+1)`, `imax a a` and
+`imax ≤1 _` where the kernel builds levels, and in a census of the 522k level comparisons
+performed while checking Lean+Std+Batteries, 99.8% of the levels reaching them were
+`imax`-free.
+
+Such a level's canonical form is flat: its sublevels are `C(∅, K)` and one `V({x}, x, kₓ)`
+per parameter, nothing is ever subsumed (a condition set is `∅` or a singleton, and the `C`
+node carries no variables), and each `imax` chain is a single edge. So the whole `NormLevel`
+can be replaced by a sorted merge, and the tree read off directly. Note that every parameter
+occurrence contributes its offset to the constant as well, so `K` dominates every `kₓ` and
+the reified children never need their `imax` guard.
+-/
+
+/-- The map a run of flat data stands for: the constant at the root (absent when zero) and
+`V({x}, x, k)` at each singleton key. Note this inserts the keys in sorted order, whereas
+`normalizeAux` inserts them in traversal order, so the two build the same entries in
+differently balanced trees — everything downstream compares maps entry by entry. -/
+def toNormLevel (c : Nat) (vs : List VarNode) : NormLevel :=
+  vs.foldl (fun s v => s.insert [v.var] ⟨0, [v]⟩)
+    (if c = 0 then {} else (∅ : NormLevel).insert [] ⟨c, []⟩)
+
+/-- Collect the largest constant and the largest offset of each parameter, throwing the
+`NormLevel` built from what has been collected so far on reaching an `imax`, so that
+`normalizeAux` picks up from there rather than retraversing. -/
+def flatAux : Level → Nat → Nat × List VarNode → Except NormLevel (Nat × List VarNode)
+  | .zero, k, (c, vs) => .ok (Nat.max c k, vs)
+  | .succ l, k, acc => flatAux l (k+1) acc
+  | .max a b, k, acc =>
+    match flatAux a k acc with
+    | .ok acc => flatAux b k acc
+    | .error s => .error (normalizeAux b [] k s)
+  | .param x, k, (c, vs) => .ok (Nat.max c k, VarNode.addVar x k vs)
+  | .mvar _, _, acc => .ok acc
+  | l@(.imax ..), k, (c, vs) => .error (normalizeAux l [] k (toNormLevel c vs))
+
+/-- The tree `toTree` builds for a flat level: the constant at the root, and one child per
+parameter holding `V({x}, x, kₓ)` — dropped when `kₓ = 0`, as the edge already provides it. -/
+def flatTree (c : Nat) (vs : List VarNode) : Tree :=
+  ⟨c, [], vs.map fun v => (v.var, ⟨0, if v.offset == 0 then [] else [v], []⟩)⟩
 
 end Normalize
 
-def normalize' (l : Level) : Level := (Normalize.normalize l (paths := true)).toTree.reify
+def normalize' (l : Level) : Level :=
+  match Normalize.flatAux l 0 (0, []) with
+  | .ok (c, vs) => (Normalize.flatTree c vs).reify
+  | .error s => s.subsumption.toTree.reify
 
 /-- A transparent structural equality test for levels.  Unlike `Level.beq`,
 this test has no opaque runtime contract, so its successful branch can be used
@@ -264,12 +360,19 @@ def isStructEq : Level → Level → Bool
   | .mvar ⟨u⟩, .mvar ⟨v⟩ => u == v
   | _, _ => false
 
+/-- Core's `isEquiv` is sound but incomplete, so it can be used as a fast path: when it
+accepts, the levels really are equivalent, and when it rejects we fall back to the complete
+check. Over the 261k level comparisons performed while checking Lean+Std+Batteries this
+filter decided every single real equivalence, leaving only the genuinely inequivalent 0.1%
+to the fallback — and it is roughly 20× cheaper than normalizing. -/
 def isEquiv' (u v : Level) : Bool :=
-  isStructEq u v || Normalize.normalize u == Normalize.normalize v
+  isEquiv u v || Normalize.normalize u == Normalize.normalize v
 
 def isEquivList : List Level → List Level → Bool := List.all2 isEquiv'
 
-def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize u)
+/-- Core's `geq` as a fast path, on the same grounds as `isEquiv'`. -/
+def geq' (u v : Level) : Bool :=
+  geq u v || (Normalize.normalize v).le (Normalize.normalize u)
 
 -- local elab "normalize " l:level : command => do
 --   Elab.Command.runTermElabM fun _ => do
@@ -287,7 +390,7 @@ def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize
 -- #guard_msgs in normalize max u 1
 -- /-- info: u -/
 -- #guard_msgs in normalize imax 1 u
--- /-- info: max 1 (imax (u+1) u) -/
+-- /-- info: max 1 (imax (u + 1) u) -/
 -- #guard_msgs in normalize u+1
 -- /-- info: imax 2 u -/
 -- #guard_msgs in normalize imax 2 u
@@ -297,7 +400,7 @@ def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize
 -- #guard_msgs in normalize max (imax (imax u v) w) (imax (imax u w) v)
 -- /-- info: u -/
 -- #guard_msgs in normalize imax u u
--- /-- info: max 1 (imax (u+1) u) -/
+-- /-- info: max 1 (imax (u + 1) u) -/
 -- #guard_msgs in normalize imax u (u+1)
--- /-- info: max 1 (imax (max (v+1) (imax (u+1) u)) v) -/
+-- /-- info: max 1 (imax (max (v + 1) (imax (u + 1) u)) v) -/
 -- #guard_msgs in normalize imax u v + 1
diff --git a/Lean4Lean/Primitive.lean b/Lean4Lean/Primitive.lean
index fae0c93a..3853cf35 100644
--- a/Lean4Lean/Primitive.lean
+++ b/Lean4Lean/Primitive.lean
@@ -244,6 +244,7 @@ def unfoldNatWellFounded (e : Expr) (fvs : Array Expr) (eq_def : Expr) (fail : 
   return (← getLCtx).mkLambda fvs rhs
 
 def checkPrimitiveDef (v : DefinitionVal) : M Bool := do
+  unless v.safety == .safe do return false
   let fail {α} : M α := throw <| .other s!"invalid form for primitive def {v.name}"
   let tru := q(true)
   let fal := q(false)
diff --git a/Lean4Lean/Quot.lean b/Lean4Lean/Quot.lean
index 194b3a47..d6b55199 100644
--- a/Lean4Lean/Quot.lean
+++ b/Lean4Lean/Quot.lean
@@ -38,6 +38,10 @@ def checkEqType (env : Environment) : Except Exception Unit := do
 def Environment.addQuot (env : Environment) : Except Exception Environment := do
   if env.quotInit then return env
   checkEqType env
+  env.checkName ``Quot
+  env.checkName ``Quot.mk
+  env.checkName ``Quot.lift
+  env.checkName ``Quot.ind
   ExprBuildT.run do
   let u := .param `u
   withLocalDecl `α .implicit (.sort u) fun α => do
@@ -74,7 +78,7 @@ def Environment.addQuot (env : Environment) : Except Exception Environment := do
   let all_quot := (← read).mkForall #[a] <| .app β quotMk_a
   withLocalDecl `q .implicit quot_r fun q => do
   -- constant Quot.ind.{u} {α : Sort u} {r : α → α → Prop} {β : @Quot.{u} α r → Prop} :
-  --   (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q */
+  --   (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q
   let env := env.add <| .quotInfo {
     name := ``Quot.ind, kind := .ind, levelParams := [`u]
     type := (← read).mkForall #[α, r, β] <|
@@ -82,6 +86,22 @@ def Environment.addQuot (env : Environment) : Except Exception Environment := do
   }
   return markQuotInit env
 
+/-- Reduces the head application of a quotient eliminator as follows:
+
+```
+Quot.lift.{u, v} {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) :
+  (∀ a b : α, r a b → f a = f b) → @Quot.{u} α r → β
+
+Quot.lift f h (Quot.mk r a) ... ⟶ f a ...
+```
+
+```
+Quot.ind.{u} {α : Sort u} {r : α → α → Prop} {β : @Quot.{u} α r → Prop} :
+  (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q
+
+Quot.ind p (Quot.mk r a) ... ⟶ p a ...
+```
+-/
 def quotReduceRec [Monad m] (e : Expr) (whnf : Expr → m Expr) : m (Option Expr) := do
   let .const fn _ := e.getAppFn | return none
   let cont mkPos argPos := do
diff --git a/Lean4Lean/Std/Ord.lean b/Lean4Lean/Std/Ord.lean
new file mode 100644
index 00000000..f7913172
--- /dev/null
+++ b/Lean4Lean/Std/Ord.lean
@@ -0,0 +1,52 @@
+import Init.Data.Order.Ord
+
+/-!
+A device for proving `Std.TransCmp` for comparisons defined by *lexicographic products*, used for
+`Lean.Name.cmp` in `Lean4Lean.Verify.Name` and for the level order in `Lean4Lean.Verify.NormLt`.
+
+Transitivity of a lexicographic product needs more than transitivity of its components: when the
+first components compare `.eq` one has to know they compare `.eq` *in both directions* before the
+second components can be consulted. Recursive comparisons therefore do not prove `isLE_trans` at a
+triple `(a, b, c)` from `isLE_trans` at the sub-triple alone; one needs its rotations too. `Rot`
+below packages the three rotations, which is exactly the statement that goes through the induction.
+-/
+
+namespace Lean4Lean
+open Std
+
+/-- The three rotations of transitivity for a comparison at a triple `a`, `b`, `c`, where
+`x = cmp a b`, `y = cmp b c`, `z = cmp a c`. Note that the second and third components are the
+first one at the rotated triples `(c, a, b)` and `(b, c, a)`, rewritten with `Ordering.swap`. -/
+def Rot (x y z : Ordering) : Prop :=
+  (x.isLE → y.isLE → z.isLE) ∧
+  (z.swap.isLE → x.isLE → y.swap.isLE) ∧
+  (y.isLE → z.swap.isLE → x.swap.isLE)
+
+/-- Lexicographic products satisfy `Rot` if the components do. The second component's rotations
+are only required when the first components are all `.eq`; this matters when the second component
+is a comparison that is only meaningful where the first component does not already decide, as for
+the level order, whose structural component compares unrelated constructors as `.eq`. -/
+theorem Rot.then' : Rot x y z → (x = .eq → y = .eq → z = .eq → Rot x' y' z') →
+    Rot (x.then x') (y.then y') (z.then z') := by
+  cases x <;> cases y <;> simp_all [Rot]; cases z <;> simp
+
+theorem Rot.then {x y z x' y' z' : Ordering}
+    (R : Rot x y z) (R' : Rot x' y' z') : Rot (x.then x') (y.then y') (z.then z') :=
+  R.then' fun _ _ _ => R'
+
+/-- Any `TransCmp` gives `Rot` at every triple: the rotations are `isLE_trans` at the rotated
+triples, rewritten with `OrientedCmp.eq_swap`. -/
+theorem Rot.of_transCmp {α} {cmp : α → α → Ordering} [TransCmp cmp] (a b c : α) :
+    Rot (cmp a b) (cmp b c) (cmp a c) := by
+  refine ⟨fun h₁ h₂ => TransCmp.isLE_trans h₁ h₂, fun h₁ h₂ => ?_, fun h₁ h₂ => ?_⟩ <;>
+    rw [← OrientedCmp.eq_swap (cmp := cmp)] at * <;>
+    exact TransCmp.isLE_trans h₁ h₂
+
+/-- `Rot` at every triple, plus orientedness, is exactly `TransCmp`. -/
+theorem TransCmp.of_rot {α} {cmp : α → α → Ordering}
+    (swap : ∀ a b : α, cmp a b = (cmp b a).swap)
+    (rot : ∀ a b c : α, Rot (cmp a b) (cmp b c) (cmp a c)) : TransCmp cmp where
+  eq_swap := swap ..
+  isLE_trans h₁ h₂ := (rot ..).1 h₁ h₂
+
+end Lean4Lean
diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean
index dc420f92..29d37108 100644
--- a/Lean4Lean/Tests.lean
+++ b/Lean4Lean/Tests.lean
@@ -1 +1,6 @@
 import Lean4Lean.Tests.Toolchain
+import Lean4Lean.Tests.Environment
+import Lean4Lean.Tests.LevelStd
+import Lean4Lean.Tests.LiteralReadiness
+import Lean4Lean.Tests.NotationPreludeReplay
+import Lean4Lean.Tests.ProjectionExpressibility
diff --git a/Lean4Lean/Tests/DeclFVar.lean b/Lean4Lean/Tests/DeclFVar.lean
new file mode 100644
index 00000000..c3e4c4c9
--- /dev/null
+++ b/Lean4Lean/Tests/DeclFVar.lean
@@ -0,0 +1,99 @@
+import Lean4Lean.Environment
+
+/-!
+Regression test for the free variable check on declaration *values*.
+
+`check_no_metavar_no_fvar` is called on the value in three places in the C++ kernel:
+`add_definition` (safe branch), `add_theorem`, and -- since leanprover/lean4#14498 --
+`add_opaque`. lean4lean had none of them.
+
+The first two were removed deliberately, on the grounds that a free variable in the value
+cannot survive type checking anyway. That argument is wrong. It holds only while inference
+always consults the local context, and inference also answers from its cache: since the
+type and then the value are checked by the *same* `TypeChecker.State` -- exactly as C++
+shares one `type_checker` -- a declaration whose type is inferred by pushing a free
+variable into the local context leaves that variable's type in `inferTypeI`. The value can
+then name the variable, inference answers from the cache instead of the (already popped)
+local context, and the declaration is accepted. With a type that beta-reduces to `False`
+this proves `False` (leanprover/lean4#14484).
+
+Half of that argument is true, and that is what made it plausible: without these checks an
+fvar that was never primed into the cache is still rejected, by inference, as `unknown free
+variable`. Only the primed one slips through. Once the checks are restored they run before
+inference, so both are rejected as `declaration has free variables` and the two cases are
+no longer distinguishable from inside the test -- the assertion below pins the rejection
+message so that a rejection coming from some *other* path is not silently accepted as
+success.
+
+The leaked variable is `_kernel_fresh.2` because `TypeChecker.State.ngen` uses that prefix
+and starts at that index; if either changes, these declarations stop exercising the cache
+path and only pin that some free variable is rejected, which was never in doubt.
+
+The declarations are built by hand rather than elaborated, so that the environment does
+not already contain them and only the kernel path is exercised.
+-/
+
+namespace Lean4Lean.Tests.DeclFVar
+
+open Lean
+
+/-- `(fun _ : False → False => False) (fun h : False => h)`.
+
+This beta-reduces to `False`, so it is a legitimate type, but inferring it pushes
+`_kernel_fresh.1 : False → False` and `_kernel_fresh.2 : False` through the local context,
+leaving them in the inference cache. -/
+def cachePrimingType : Expr :=
+  let falseE := mkConst ``False
+  let falseToFalse := Expr.forallE `h falseE falseE .default
+  let identity := Expr.lam `h falseE (.bvar 0) .default
+  .app (.lam `_ falseToFalse falseE .default) identity
+
+/-- The value that only the inference cache still knows about. -/
+def leakedFVar : Expr := .fvar { name := .num `_kernel_fresh 2 }
+
+def thmDecl (name : Name) (value : Expr) : Declaration :=
+  .thmDecl { name, levelParams := [], type := cachePrimingType, value }
+
+def defnDecl (name : Name) (value : Expr) : Declaration :=
+  .defnDecl { name, levelParams := [], type := cachePrimingType, value
+              hints := .abbrev, safety := .safe }
+
+def opaqueDecl (name : Name) (value : Expr) : Declaration :=
+  .opaqueDecl { name, levelParams := [], type := cachePrimingType, value, isUnsafe := false }
+
+/-- Closed counterparts, so that a blanket rejection cannot pass this test. -/
+def goodThm : Declaration :=
+  .thmDecl { name := `GoodThm, levelParams := [], type := mkConst ``True,
+             value := mkConst ``True.intro }
+def goodDefn : Declaration :=
+  .defnDecl { name := `GoodDefn, levelParams := [], type := mkConst ``Nat,
+              value := mkRawNatLit 0, hints := .abbrev, safety := .safe }
+def goodOpaque : Declaration :=
+  .opaqueDecl { name := `GoodOpaque, levelParams := [], type := mkConst ``Nat,
+                value := mkRawNatLit 0, isUnsafe := false }
+
+run_meta do
+  let kenv := (← getEnv).toKernelEnv
+
+  let errorOf (decl : Declaration) : MetaM (Option String) := do
+    match Lean4Lean.addDecl kenv decl with
+    | .ok _ => return none
+    | .error e => return some (← (e.toMessageData {}).toString)
+  let mentions (pat : String) (s : String) : Bool := (s.splitOn pat).length > 1
+
+  for (kind, mk) in [("theorem", thmDecl), ("safe definition", defnDecl), ("opaque", opaqueDecl)] do
+    -- The value that the inference cache leaks must be rejected *by the fvar check*.
+    match ← errorOf (mk `Bad leakedFVar) with
+    | none => throwError "{kind} value containing a leaked free variable was accepted"
+    | some msg =>
+      unless mentions "declaration has free variables" msg do
+        throwError "{kind} leaked free variable was rejected, but not by the free variable \
+          check, so this test no longer pins the cache path: {msg}"
+
+  -- ... and closed values must still go through.
+  for (kind, decl) in [("theorem", goodThm), ("safe definition", goodDefn),
+                       ("opaque", goodOpaque)] do
+    if let some msg ← errorOf decl then
+      throwError "closed {kind} was rejected: {msg}"
+
+end Lean4Lean.Tests.DeclFVar
diff --git a/Lean4Lean/Tests/Environment.lean b/Lean4Lean/Tests/Environment.lean
new file mode 100644
index 00000000..dc80794e
--- /dev/null
+++ b/Lean4Lean/Tests/Environment.lean
@@ -0,0 +1,25 @@
+import Lean4Lean.Environment
+
+/-!
+Front-end declaration checks that are not covered by `Lean4Lean.Tests.KernelHardening`.
+
+The mutual-block level parameter and duplicate name checks live there, since v4.33.0-rc2
+made the kernel reject both (lean4#14608).
+-/
+
+namespace Lean4Lean.Tests.Environment
+
+open Lean
+
+run_meta
+  let env ← Lean.getEnv
+  let some (.defnInfo natAdd) := env.toKernelEnv.find? ``Nat.add
+    | throwError "Nat.add is not a definition"
+  let partialNatAdd := { natAdd with safety := DefinitionSafety.partial }
+  match (Lean4Lean.Environment.checkPrimitiveDef partialNatAdd).run env.toKernelEnv
+      (lparams := partialNatAdd.levelParams) with
+  | .ok false => pure ()
+  | .ok true => throwError "a partial definition was accepted as a primitive"
+  | .error _ => throwError "the partial primitive check failed unexpectedly"
+
+end Lean4Lean.Tests.Environment
diff --git a/Lean4Lean/Tests/KernelHardening.lean b/Lean4Lean/Tests/KernelHardening.lean
new file mode 100644
index 00000000..6386c313
--- /dev/null
+++ b/Lean4Lean/Tests/KernelHardening.lean
@@ -0,0 +1,208 @@
+import Lean4Lean.Environment
+
+/-!
+Executable regressions for the kernel hardening merged between Lean v4.32.2 and
+v4.33.0-rc2.  The declarations are assembled manually so they exercise
+`Lean4Lean.addDecl` and `Lean4Lean.TypeChecker` directly.
+-/
+
+namespace Lean4Lean.Tests.KernelHardening
+
+open Lean Lean4Lean TypeChecker
+
+private def errorOf (r : Except Kernel.Exception α) : MetaM (Option String) := do
+  match r with
+  | .ok _ => return none
+  | .error e => return some (← (e.toMessageData {}).toString)
+
+private def mentions (pat s : String) : Bool := (s.splitOn pat).length > 1
+
+private def expectError (label pat : String) (r : Except Kernel.Exception α) : MetaM Unit := do
+  match ← errorOf r with
+  | none => throwError "{label} was accepted"
+  | some msg => unless mentions pat msg do throwError "{label} failed for the wrong reason: {msg}"
+
+private def runM (r : Except Kernel.Exception α) : MetaM α := do
+  match r with
+  | .ok a => pure a
+  | .error e => throwError "kernel operation failed: {← (e.toMessageData {}).toString}"
+
+private def mkPartial (n : Name) (lparams : List Name) (type value : Expr) : DefinitionVal :=
+  { name := n, levelParams := lparams, type, value, hints := .opaque, safety := .partial }
+
+private def universeTy : Expr :=
+  .forallE `x (.sort (.param `u)) (.sort (.param `u)) .default
+
+private def universeVal : Expr :=
+  .lam `x (.sort (.param `u)) (.bvar 0) .default
+
+private def imaxProp : Expr := .sort (.imax (.succ .zero) .zero)
+
+private def imaxDataDecl : Declaration :=
+  .inductDecl [] 0 [{
+    name := `L4LKIPData
+    type := imaxProp
+    ctors := [{
+      name := `L4LKIPData.mk
+      type := .forallE `b (.const ``Bool []) (.const `L4LKIPData []) .default }]
+  }] false
+
+/-- The auxiliary name the kernel generates for a nested `List` occurrence. -/
+private def auxListName : Name := (`_nested ++ `List).appendIndexAfter 1
+
+/-- lean4#14616.  `mk` nests `List L4LKNReal`, so eliminating it makes the kernel generate
+`_nested.List_1`; `bad` then names that auxiliary.  This is the form that *discriminates*:
+without the check the declaration is accepted, and `restoreNested` rewrites the stored type of
+`bad` to `List L4LKNReal → L4LKNReal`, which the kernel never checked.  A declaration naming an
+auxiliary that never exists is instead rejected as an unknown constant either way. -/
+private def nestedAuxRealDecl : Declaration :=
+  .inductDecl [] 0 [{
+    name := `L4LKNReal
+    type := .sort 1
+    ctors := [
+      { name := `L4LKNReal.mk
+        type := .forallE `xs (.app (.const ``List [.zero]) (.const `L4LKNReal []))
+          (.const `L4LKNReal []) .default },
+      { name := `L4LKNReal.bad
+        type := .forallE `y (.const auxListName []) (.const `L4LKNReal []) .default }]
+  }] false
+
+private def nestedAuxProjDecl : Declaration :=
+  .inductDecl [] 0 [{
+    name := `L4LKNProj
+    type := .sort .zero
+    ctors := [{
+      name := `L4LKNProj.mk
+      type := .forallE `x (.const ``Nat [])
+        (.forallE `y (.proj `_nested.L4LHost_1 0 (.bvar 0))
+          (.const `L4LKNProj []) .default) .default }]
+  }] false
+
+private def nestedBadDecl (bad : Expr) (name : Name) : Declaration :=
+  let ind := fun a => .app (.const name []) a
+  .inductDecl [] 1 [{
+    name
+    type := .forallE `α (.sort 1) (.sort 1) .default
+    ctors := [{
+      name := name ++ `mk
+      type := .forallE `α (.sort 1)
+        (.forallE `xs (.app (.const ``Array [.zero]) (ind bad))
+          (ind (.bvar 1)) .default) .default }]
+  }] false
+
+/-- lean4#14613: projecting the field back out of a `Sort (imax 1 0)` proof would break proof
+irrelevance, so `inferProj` must reject it. -/
+private def imaxLeakDecl : Declaration :=
+  .defnDecl {
+    name := `L4LKIPLeak
+    levelParams := []
+    type := .forallE `proof (.const `L4LKIPData []) (.const ``Bool []) .default
+    value := .lam `proof (.const `L4LKIPData []) (.proj `L4LKIPData 0 (.bvar 0)) .default
+    hints := .abbrev, safety := .safe }
+
+structure L4LKC where b : Bool
+inductive L4LKW : Type where | mk (p : Bool)
+inductive L4LKL (α : Type) (b : Bool) : Type where | mk
+
+/-- lean4#14576/#14577: the parametric arguments of a nested occurrence are dropped from the
+auxiliary declaration, so they escape checking unless they are checked against the environment
+that results from the declaration. Here `w.1.1` is ill typed. -/
+private def nestedIllTypedParams : Declaration :=
+  let w : Expr := .bvar 0
+  let Ew : Expr := .app (.const `L4LKE []) w
+  let b : Expr := .proj ``L4LKC 0 (.proj ``L4LKC 0 w)
+  let l : Expr := mkApp2 (.const ``L4LKL []) Ew b
+  .inductDecl [] 1 [{
+    name := `L4LKE
+    type := .forallE `w (.const ``L4LKW []) (.sort 1) .default
+    ctors := [{
+      name := `L4LKE.mk
+      type := .forallE `w (.const ``L4LKW [])
+        (.forallE `l l (.app (.const `L4LKE []) (.bvar 1)) .default) .default }]
+  }] false
+
+private partial def deepNat : Nat → Expr
+  | 0 => .const ``Nat.zero []
+  | n + 1 => .app (.const ``Nat.succ []) (deepNat n)
+
+structure ProjB where b : Nat
+
+run_meta do
+  let env := (← getEnv).toKernelEnv
+
+  -- lean4#14608 and lean4#14632: mutual blocks share level parameters and names.
+  expectError "mutual block with mismatched universe parameters"
+    "same universe level parameters" <|
+    Lean4Lean.addDecl env <| .mutualDefnDecl [
+      mkPartial `L4LMutA [`u] universeTy universeVal,
+      mkPartial `L4LMutB [] universeTy universeVal]
+  expectError "mutual block with a duplicate name" "duplicate declaration name" <|
+    Lean4Lean.addDecl env <| .mutualDefnDecl [
+      mkPartial `L4LMutDup [] (.const ``Nat []) (mkRawNatLit 0),
+      mkPartial `L4LMutDup [] (.const ``Bool []) (.const ``Bool.true [])]
+  match Lean4Lean.addDecl env <| .mutualDefnDecl [
+      mkPartial `L4LMutGoodA [] (.const ``Nat []) (mkRawNatLit 0),
+      mkPartial `L4LMutGoodB [] (.const ``Bool []) (.const ``Bool.true [])] with
+  | .error e => throwError "valid mutual block was rejected: {← (e.toMessageData {}).toString}"
+  | .ok _ => pure ()
+
+  -- lean4#14613/#14615: normalized `Prop` controls inductive classification and recursor levels.
+  let env' ← match Lean4Lean.addDecl env imaxDataDecl with
+    | .ok env' => pure env'
+    | .error e => throwError "imax-Prop inductive was rejected: {← (e.toMessageData {}).toString}"
+  let some (.recInfo recInfo) := env'.find? `L4LKIPData.rec
+    | throwError "imax-Prop recursor was not generated"
+  unless recInfo.levelParams.isEmpty do
+    throwError "imax-Prop inductive received a large-elimination universe"
+  -- ... but its field must not be projectable back out, or proof irrelevance equates
+  -- `mk false` and `mk true`.
+  expectError "projection out of an `imax`-`Prop` proof" "invalid projection" <|
+    Lean4Lean.addDecl env' imaxLeakDecl
+
+  -- lean4#14616: a constructor naming a `_nested` auxiliary the kernel really generated.
+  expectError "constructor naming a generated nested auxiliary" "reserved prefix '_nested'" <|
+    Lean4Lean.addDecl env nestedAuxRealDecl
+  -- The `Expr.proj` form of the same scan.  Note this one names an auxiliary that never exists,
+  -- so it pins the branch rather than the hole: without the check it is still rejected, as an
+  -- unknown constant.
+  expectError "constructor naming a nested auxiliary in a projection" "reserved prefix '_nested'" <|
+    Lean4Lean.addDecl env nestedAuxProjDecl
+
+  -- lean4#14576/#14577: parametric arguments dropped from the auxiliary declaration.
+  expectError "nested inductive with ill-typed dropped parameters" "invalid projection" <|
+    Lean4Lean.addDecl env nestedIllTypedParams
+
+  -- lean4#14607: validate original nested constructor types before elimination can hide them.
+  expectError "nested inductive containing a free variable" "free variables" <|
+    Lean4Lean.addDecl env <| nestedBadDecl (.fvar { name := `l4lBadFVar }) `L4LNestedFVar
+  expectError "nested inductive containing a metavariable" "metavariables" <|
+    Lean4Lean.addDecl env <| nestedBadDecl (.mvar { name := `l4lBadMVar }) `L4LNestedMVar
+
+  -- lean4#14632: projection indices are `Nat` throughout lean4lean, so an index past `2^32`
+  -- is stuck rather than truncated.  The structure *name* is deliberately not compared here;
+  -- see the projection entry in `divergences.md`.
+  let b : Expr := .app (.const ``ProjB.mk []) (mkRawNatLit 7)
+  let good : Expr := .proj ``ProjB 0 b
+  let huge : Expr := .proj ``ProjB 4294967296 b
+  let goodWhnf ← runM <| TypeChecker.M.run env (x := TypeChecker.whnf good)
+  unless goodWhnf == mkRawNatLit 7 do throwError "valid projection did not reduce"
+  let hugeWhnf ← runM <| TypeChecker.M.run env (x := TypeChecker.whnf huge)
+  unless hugeWhnf == huge do throwError "large projection index was truncated during reduction"
+  let same ← runM <| TypeChecker.M.run env (x := TypeChecker.isDefEq good good)
+  unless same do throwError "identical projections were not definitionally equal"
+  expectError "out-of-range large projection" "invalid projection" <|
+    TypeChecker.M.run env (x := TypeChecker.checkType huge)
+
+  -- lean4#13956: lean4lean's explicit fuel remains deterministic and configurable.
+  -- This fork's syntactic `isDefEq` fast path (divergence D011) answers the
+  -- app-argument checks of `checkType (deepNat 100)` without consuming
+  -- recursion fuel, so the fuel probe reduces the term instead: `whnf`
+  -- descends through the `Nat.succ` spine one method level at a time.
+  expectError "deep term with low recursion fuel" "deep recursion" <|
+    TypeChecker.M.run env (fuel := { recDepth := 1 }) (x := TypeChecker.whnf (deepNat 100))
+  match TypeChecker.M.run env (fuel := { recDepth := 1000 })
+      (x := TypeChecker.checkType (deepNat 100)) with
+  | .error e => throwError "deep term with sufficient recursion fuel failed: {← (e.toMessageData {}).toString}"
+  | .ok ty => unless ty.isConstOf ``Nat do throwError "deep term inferred an unexpected type"
+
+end Lean4Lean.Tests.KernelHardening
diff --git a/Lean4Lean/Tests/Level.lean b/Lean4Lean/Tests/Level.lean
new file mode 100644
index 00000000..8fc831de
--- /dev/null
+++ b/Lean4Lean/Tests/Level.lean
@@ -0,0 +1,137 @@
+import Lean4Lean.Level
+
+open Lean
+
+/-!
+# Regressions for the experimental level normalization
+
+Soundness of `normalize'`, `isEquiv'` and `geq'` is proved in `Verify/Level.lean`. What is
+*not* proved, and so is what these check, is canonicity of `normalize'` and completeness of
+`isEquiv'`/`geq'`.
+-/
+
+private def u : Level := .param `u
+private def v : Level := .param `v
+private def w : Level := .param `w
+private def x : Level := .param `x
+
+-- The reconstruction must depend only on the sublevels, not on which `imax` chains appeared
+-- in the input. These two have the same sublevels but different scaffolding keys; picking the
+-- chain by parent pointers into the key set reified them to different levels. Four parameters
+-- and size 10, so exhaustive fuzzing up to size 7 does not reach it.
+#guard (Level.max v (.max w (.imax (.imax (.imax u v) w) x))).isEquiv'
+       (Level.max v (.max w (.imax (.imax (.imax u w) v) x)))
+
+-- `NormLevel.le` compares sublevels, not nodes: the node `{v} => {const := 2, var := [v+0]}`
+-- of `imax 2 v` has its constant dominated at the empty key of `max 2 v` and its variable at
+-- `{v}`, and no single entry dominates both. Reachable from the constructor universe check,
+-- where it made lean4lean reject an inductive that Lean accepts.
+#guard (Level.max (.ofNat 2) v).geq' (.imax (.ofNat 2) v)
+#guard (Level.max (u.addOffset 2) v).geq' (.imax (u.addOffset 2) v)
+
+-- Subsumption drains this node, and the key has to be erased rather than left empty, or
+-- `BEq` on the normal form sees scaffolding that carries no information.
+#guard (Level.imax u (.max u v)).isEquiv' (.max u v)
+
+-- Equivalences the core `isEquiv` misses.
+#guard (Level.max v u).isEquiv' (.max (.imax u v) u)
+#guard !(Level.max v u).isEquiv (.max (.imax u v) u)
+
+/-! ### Canonical forms -/
+
+local elab "normalize " l:level : command => do
+  Elab.Command.runTermElabM fun _ => do
+    logInfo m!"{Level.normalize' (← Elab.Term.elabLevel l)}"
+
+universe u v w
+
+/-- info: max 1 u -/
+#guard_msgs in normalize max u 1
+/-- info: u -/
+#guard_msgs in normalize imax 1 u
+/-- info: imax 2 u -/
+#guard_msgs in normalize imax 2 u
+
+-- Constant absorption (`Tree.plainOffset?`): the sublevel `V({u}, u, 1)` is reified as the
+-- plain `u+1` rather than the guarded `imax (u+1) u`, because the node's constant `1` covers
+-- what the plain form contributes at `u = 0`; the constant is then redundant and dropped.
+-- Without this every offset in the input doubles the size of its normal form.
+/-- info: u + 1 -/
+#guard_msgs in normalize u+1
+/-- info: max u (v + 1) -/
+#guard_msgs in normalize max u (v+1)
+-- the constant survives when no variable's offset reaches it
+/-- info: max 2 (u + 1) -/
+#guard_msgs in normalize max 2 (u+1)
+-- and the guard survives when the constant (here 0) does not cover the offset, as it must:
+-- `u+2` is 2 at `u = 0`, where the level is 0
+/-- info: imax (u + 2) u -/
+#guard_msgs in normalize imax (u+2) u
+/-- info: max v (imax (imax u v) w) -/
+#guard_msgs in normalize max w (imax (imax u w) v)
+/-- info: max v (imax (imax u v) w) -/
+#guard_msgs in normalize max (imax (imax u v) w) (imax (imax u w) v)
+/-- info: u -/
+#guard_msgs in normalize imax u u
+/-- info: u + 1 -/
+#guard_msgs in normalize imax u (u+1)
+/-- info: max 1 (imax (max (v + 1) (imax (u + 1) u)) v) -/
+#guard_msgs in normalize imax u v + 1
+
+/-! ### Bounded exhaustive canonicity and completeness
+
+Every equivalent pair of levels must reify to the *same* level, and `isEquiv'` must accept it.
+Levels are bucketed by their values on a grid of valuations, which for levels this small
+decides equivalence.
+-/
+
+private def evalL (σ : Name → Nat) : Level → Nat
+  | .zero => 0
+  | .succ l => evalL σ l + 1
+  | .max l₁ l₂ => Nat.max (evalL σ l₁) (evalL σ l₂)
+  | .imax l₁ l₂ =>
+    match evalL σ l₂ with
+    | 0 => 0
+    | n+1 => Nat.max (evalL σ l₁) (n+1)
+  | .param n => σ n
+  | .mvar _ => 0
+
+private def levelsUpTo (n : Nat) : Array (Array Level) := Id.run do
+  let mut tbl : Array (Array Level) := #[#[]]
+  for k in [1:n+1] do
+    if k = 1 then
+      tbl := tbl.push #[.zero, .param `u, .param `v, .param `w]
+    else
+      let mut out := tbl[k-1]!.map .succ
+      for i in [1:k-1] do
+        for a in tbl[i]! do
+          for b in tbl[k-1-i]! do
+            out := out.push (.max a b)
+            out := out.push (.imax a b)
+      tbl := tbl.push out
+  return tbl
+
+private def valsOver (hi : Nat) : Array (Name → Nat) := Id.run do
+  let mut out := #[]
+  for i in [0:hi+1] do
+    for j in [0:hi+1] do
+      for k in [0:hi+1] do
+        out := out.push fun n => if n == `u then i else if n == `v then j else k
+  return out
+
+/-- Levels of size at most `sz`, grouped by value vector; every group must be a single
+`normalize'` image accepted by `isEquiv'`. -/
+private def canonical (sz : Nat) : Bool := Id.run do
+  let vals := valsOver (sz + 2)
+  let mut buckets : Std.HashMap (Array Nat) (Level × Level) := {}
+  for ls in levelsUpTo sz do
+    for l in ls do
+      let key := vals.map (evalL · l)
+      let l' := l.normalize'
+      match buckets[key]? with
+      | none => buckets := buckets.insert key (l, l')
+      | some (r, r') => if l' != r' || !l.isEquiv' r then return false
+  return true
+
+-- 852 levels in 123 equivalence classes, so 729 equivalent pairs are checked
+#guard canonical 5
diff --git a/Lean4Lean/Tests/LevelStd.lean b/Lean4Lean/Tests/LevelStd.lean
new file mode 100644
index 00000000..b87368c7
--- /dev/null
+++ b/Lean4Lean/Tests/LevelStd.lean
@@ -0,0 +1,90 @@
+import Lean4Lean.Verify.LevelStd
+
+open Lean
+
+private def p : Level := .param `p
+private def q : Level := .param `q
+private def m : Level := .mvar ⟨`m⟩
+private def n : Level := .mvar ⟨`n⟩
+
+private def atoms : Array Level := #[.zero, p, q, m, n]
+
+private def levels : Nat → Array Level
+  | 0 => atoms
+  | n + 1 =>
+    let xs := levels n
+    xs ++ xs.map .succ ++ xs.flatMap fun a =>
+      xs.flatMap fun b => #[.max a b, .imax a b]
+
+private def sampleEvery (step : Nat) : Nat → List Level → List Level
+  | _, [] => []
+  | i, u :: us =>
+    if i % step == 0 then u :: sampleEvery step (i + 1) us
+    else sampleEvery step (i + 1) us
+
+private def generatedSamples : Array Level :=
+  (sampleEvery 12 0 (levels 2).toList).toArray
+
+-- Exercise the offset boundaries used when normalization drops explicit levels
+-- or deduplicates levels with the same base.
+private def trickySamples : Array Level := #[
+  .max (.succ .zero) (.succ p),
+  .max (.succ (.succ .zero)) (.succ p),
+  .max (.succ (.succ .zero)) (.succ (.succ p)),
+  .max (.succ (.succ (.succ .zero))) (.succ (.succ p)),
+  .max (.succ p) (.succ (.succ p)),
+  .max (.succ (.succ p)) (.succ p),
+  .max (.max (.succ (.succ .zero)) (.succ q)) (.succ (.succ p)),
+  .succ (.max (.succ (.succ .zero)) (.imax p (.succ q))),
+  .imax (.succ (.succ p)) (.max (.succ (.succ .zero)) q)]
+
+private def samples := generatedSamples ++ trickySamples
+
+private def valuations : Array (Nat × Nat × Nat × Nat) := #[
+  (0, 0, 0, 0), (0, 1, 0, 1), (1, 0, 1, 0),
+  (1, 1, 1, 1), (2, 5, 3, 7), (5, 2, 7, 3)]
+
+private def paramVal (v : Nat × Nat × Nat × Nat) : Name → Nat
+  | `p => v.1
+  | `q => v.2.1
+  | _ => 0
+
+private def mvarVal (v : Nat × Nat × Nat × Nat) : LMVarId → Nat
+  | ⟨`m⟩ => v.2.2.1
+  | ⟨`n⟩ => v.2.2.2
+  | _ => 0
+
+-- Finite regression coverage for `Level.Semantics.eval_normalize`.
+#guard samples.all fun u => valuations.all fun v =>
+  Level.eval (paramVal v) (mvarVal v) u.normalize ==
+    Level.eval (paramVal v) (mvarVal v) u
+
+-- Finite regression coverage for `Level.normalize_eq`: exhaustive over the 7320 levels of depth
+-- at most 2 over `atoms`, plus 28920 depth-3 levels built from a sample of them.
+private def deeperSamples : Array Level :=
+  let sample := (levels 2).zipIdx.filterMap fun (u, i) => if i % 61 == 0 then some u else none
+  sample.map .succ ++ sample.flatMap fun a =>
+    (levels 1).flatMap fun b => #[.max a b, .imax a b, .max b a, .imax b a]
+
+#guard (levels 2).all fun u => u.normalize == Level.Total.normalize u
+#guard deeperSamples.all fun u => u.normalize == Level.Total.normalize u
+
+/--
+info: 'Lean.Level.isEquiv_wf' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq]
+-/
+#guard_msgs in #print axioms Level.isEquiv_wf
+
+/--
+info: 'Lean.Level.geq_wf' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq]
+-/
+#guard_msgs in #print axioms Level.geq_wf
diff --git a/Lean4Lean/Tests/LiteralReadiness.lean b/Lean4Lean/Tests/LiteralReadiness.lean
new file mode 100644
index 00000000..fae0db67
--- /dev/null
+++ b/Lean4Lean/Tests/LiteralReadiness.lean
@@ -0,0 +1,99 @@
+import Lean4Lean.Theory.InductiveFixtures
+import Lean4Lean.Theory.Literals
+import Lean4Lean.Verify.Typing.Lemmas
+
+/-! # Literal readiness fixtures
+
+These checks pin the consumer-neutral prelude descriptors used by
+`VEnv.PreludeReady` to Lean's real compiled metadata, then exercise direct and
+constructor-unfolded literals with notation-heavy values.
+-/
+
+namespace Lean4Lean.Tests.LiteralReadiness
+
+open Lean
+
+/-! The manual Theory descriptors are exactly the declarations already
+checked against the kernel by `Theory.InductiveFixtures`. -/
+
+example : LiteralPrelude.boolType = InductiveFixtures.boolType := rfl
+example : LiteralPrelude.natType = InductiveFixtures.natType := rfl
+example : LiteralPrelude.listType = InductiveFixtures.listType := rfl
+
+example : LiteralPrelude.char = vconst(type_of% @Char) := rfl
+example : LiteralPrelude.charOfNat = vconst(type_of% @Char.ofNat) := rfl
+example : LiteralPrelude.string = vconst(type_of% @String) := rfl
+example : LiteralPrelude.stringOfList = vconst(type_of% @String.ofList) := rfl
+
+/-! The readiness contract's recursor and iota descriptors also agree
+definitionally with the kernel declarations.  List's two universe parameters
+use the same explicit occurrence-to-kernel permutation as the underlying
+inductive adequacy fixture. -/
+
+private def permC (ci : VConstant) (ls : List VLevel) : VConstant :=
+  ⟨ci.uvars, ci.type.instL ls⟩
+
+private def permE (df : VDefEq) (ls : List VLevel) : VDefEq :=
+  ⟨df.uvars, df.lhs.instL ls, df.rhs.instL ls, df.type.instL ls⟩
+
+example : LiteralPrelude.boolRec = vconst(type_of% @Bool.rec) := rfl
+example : LiteralPrelude.boolIotas[0]? =
+    some (vdefeq(motive f t => @Bool.rec motive f t .false ≡ f)) := rfl
+example : LiteralPrelude.boolIotas[1]? =
+    some (vdefeq(motive f t => @Bool.rec motive f t .true ≡ t)) := rfl
+
+example : LiteralPrelude.natRec = vconst(type_of% @Nat.rec) := rfl
+example : LiteralPrelude.natIotas[0]? =
+    some (vdefeq(motive z s => @Nat.rec motive z s .zero ≡ z)) := rfl
+example : LiteralPrelude.natIotas[1]? =
+    some (vdefeq(motive z s n =>
+      @Nat.rec motive z s (.succ n) ≡ s n (@Nat.rec motive z s n))) := rfl
+
+example : LiteralPrelude.listRec =
+    permC (vconst(type_of% @List.rec)) [.param 1, .param 0] := rfl
+example : LiteralPrelude.listIotas[0]? =
+    some (permE (vdefeq(α motive n c => @List.rec α motive n c (@List.nil α) ≡ n))
+      [.param 1, .param 0]) := rfl
+example : LiteralPrelude.listIotas[1]? =
+    some (permE (vdefeq(α motive n c hd tl =>
+        @List.rec α motive n c (@List.cons α hd tl) ≡
+          c hd tl (@List.rec α motive n c tl)))
+      [.param 1, .param 0]) := rfl
+
+section
+
+variable {env : VEnv} (ready : env.PreludeReady)
+
+example {env' : VEnv} (henv : env ≤ env') (hordered : env'.Ordered) :
+    env'.PreludeReady :=
+  ready.mono henv hordered
+
+example {env' : VEnv} (name : Name) (ci : VConstant) (hci : ci.WF env)
+    (hadd : env.addConst name ci = some env') : env'.PreludeReady :=
+  ready.addConst hci hadd
+
+example (df : VDefEq) (hdf : df.WF env) :
+    (env.addDefEq df).PreludeReady :=
+  ready.addDefEq hdf
+
+example : VExpr.WF env 0 [] (VExpr.trLiteral (.natVal 1_234_567)) :=
+  ready.trLiteral_wf _ (ready.containsLits _)
+
+example : VExpr.WF env 3 []
+    (VExpr.trLiteral (.strVal "Lean 4: λ → ☃ — 12,345")) :=
+  ready.trLiteral_wf _ (ready.containsLits _)
+
+example (h : TrExprS env [] []
+    (Literal.toConstructor (.strVal "constructor ↔ direct")) w) :
+    w = VExpr.trLiteral (.strVal "constructor ↔ direct") ∧
+      VExpr.WF env 0 [] w :=
+  h.toConstructor_ready ready (ready.containsLits _)
+
+example {l : Literal}
+    (h : TrExprS env [] [] (Literal.toConstructor l) w) :
+    w = VExpr.trLiteral l :=
+  h.toConstructor_eq
+
+end
+
+end Lean4Lean.Tests.LiteralReadiness
diff --git a/Lean4Lean/Tests/NotationPreludeFixture.lean b/Lean4Lean/Tests/NotationPreludeFixture.lean
new file mode 100644
index 00000000..4e1e82d6
--- /dev/null
+++ b/Lean4Lean/Tests/NotationPreludeFixture.lean
@@ -0,0 +1,32 @@
+/-!
+# Notation-heavy prelude fixture
+
+Unlike the older `IndexedVec` fixture, these declarations deliberately keep
+ordinary numeral, arithmetic, list, array, product, conditional, comparison,
+and string notation in the source.  Their compiled metadata therefore pulls
+the real `OfNat`/`HAdd` and literal dependency prefix into fresh replay.
+-/
+
+namespace Lean4Lean.Tests.NotationPreludeFixture
+
+inductive NotationVec (α : Type u) : Nat → Type u where
+  | nil : NotationVec α 0
+  | cons {n : Nat} : α → NotationVec α n → NotationVec α (n + 1)
+
+def sample : NotationVec Nat (1 + 1) :=
+  .cons 37 (.cons 5 .nil)
+
+def notationList : List (Nat × String) :=
+  [(0, "zero"), (1 + 1, "two"), (if 2 < 3 then 3 else 4, "three")]
+
+def notationArray : Array (Nat × String) :=
+  #[(5, "five"), (2 + 4, "six")]
+
+/-- One root whose type and value retain the complete fixture dependency
+closure for replay. -/
+def bundled :
+    NotationVec Nat (1 + 1) ×
+      (List (Nat × String) × Array (Nat × String)) :=
+  (sample, notationList, notationArray)
+
+end Lean4Lean.Tests.NotationPreludeFixture
diff --git a/Lean4Lean/Tests/NotationPreludeReplay.lean b/Lean4Lean/Tests/NotationPreludeReplay.lean
new file mode 100644
index 00000000..0ceb0f28
--- /dev/null
+++ b/Lean4Lean/Tests/NotationPreludeReplay.lean
@@ -0,0 +1,54 @@
+import Lean4Lean.Replay
+import Lean4Lean.Tests.NotationPreludeFixture
+
+/-!
+# Fresh notation-prelude replay
+
+This is an executable replay from an empty kernel environment over the real
+compiled dependency closure of `bundled`.  In particular, no hand-built
+Theory environment or abstract existence witness stands in for the prelude
+prefix selected by the stored metadata.
+-/
+
+namespace Lean4Lean.Tests.NotationPreludeReplay
+
+open Lean
+
+private def fixtureModule : Name :=
+  `Lean4Lean.Tests.NotationPreludeFixture
+
+private def fixtureRoot : Name :=
+  ``Lean4Lean.Tests.NotationPreludeFixture.bundled
+
+/-- Return the actual fresh kernel environment as well as the count so the
+test can check that the notation-selected prelude prefix was really installed.
+This is the same operation as `Replay.replayFromFresh` specialized to one
+dependency root. -/
+private unsafe def replayNotationPrefix :
+    IO (Nat × Lean.Kernel.Environment) := do
+  Lean.withImportModules #[fixtureModule] {} (trustLevel := 0) fun env => do
+    let context : Lean4Lean.Replay.Context := {
+      newConstants := env.constants.map₁
+      checkQuot := false }
+    Lean4Lean.Replay.replay context (.empty fixtureModule) (some fixtureRoot)
+
+run_cmd do
+  let (count, replayed) ← replayNotationPrefix
+  unless count = 296 do
+    throwError "notation-heavy fresh replay added {count} declarations; expected 296"
+  let required := #[
+    ``OfNat.ofNat,
+    ``HAdd.hAdd,
+    ``String.ofList,
+    ``Char.ofNat,
+    ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec,
+    ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.nil,
+    ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.cons,
+    ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.rec,
+    fixtureRoot]
+  for name in required do
+    unless (replayed.constants.find? name).isSome do
+      throwError "notation-heavy fresh replay omitted {name}"
+  logInfo m!"notation-heavy fresh replay OK ({count} declarations)"
+
+end Lean4Lean.Tests.NotationPreludeReplay
diff --git a/Lean4Lean/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean
new file mode 100644
index 00000000..57320417
--- /dev/null
+++ b/Lean4Lean/Tests/ProjectionExpressibility.lean
@@ -0,0 +1,1317 @@
+import Lean4Lean.Theory.Meta
+import Lean4Lean.Theory.Projection
+import Lean4Lean.Theory.Typing.InductiveLemmas
+
+/-!
+# Projection expressibility fixtures
+
+The main fixture is simultaneously parameterized, universe-polymorphic, and
+dependent: the final field type mentions the preceding projection.  It is
+small enough that the complete recursor encoding remains definitionally
+inspectable.
+-/
+
+namespace Lean4Lean.Tests.ProjectionExpressibility
+
+open Lean4Lean VInductDecl
+
+universe u v
+
+structure DependentRecord (α : Type u) (family : α → Type v) where
+  key : α
+  value : family key
+
+def dependentRecordCtor : VConstVal :=
+  ⟨vconst(type_of% @DependentRecord.mk), ``DependentRecord.mk⟩
+
+def dependentRecordType : VInductiveType where
+  name := ``DependentRecord
+  uvars := 2
+  type := vconst(type_of% @DependentRecord).type
+  ctors := [dependentRecordCtor]
+
+def dependentRecordDecl : VInductDecl :=
+  ⟨2, 2, [dependentRecordType]⟩
+
+example : dependentRecordDecl.checked?.isSome = true := rfl
+
+def dependentRecordChecked : dependentRecordDecl.Checked :=
+  dependentRecordDecl.checked?.get (by decide)
+
+def dependentRecordGeneration : dependentRecordDecl.GenerationChecked :=
+  dependentRecordChecked.identityGeneration
+
+def dependentRecordView : VStructureView where
+  source := dependentRecordDecl
+  generation := dependentRecordGeneration
+  constructor := dependentRecordGeneration.block.ctorPairs[0]
+  constructor_eq := rfl
+  raw_indices_eq := rfl
+  checked_indices_eq := rfl
+  recursive_eq := rfl
+  fieldSorts := [.succ (.param 0), .succ (.param 1)]
+  fieldSorts_length := rfl
+
+def dependentRecordEnv : VEnv :=
+  (VEnv.empty.addInductGeneration dependentRecordGeneration).get (by decide)
+
+theorem dependentRecord_add :
+    VEnv.empty.addInductGeneration dependentRecordGeneration =
+      some dependentRecordEnv := rfl
+
+theorem dependentRecord_trace :
+    Nonempty (VEnv.AddInductGenerationTrace VEnv.empty
+      dependentRecordEnv dependentRecordGeneration) :=
+  VEnv.addInductGeneration_trace dependentRecord_add
+
+theorem dependentRecordDecl_wf :
+    dependentRecordDecl.WF VEnv.empty := by
+  refine ⟨rfl, ?_⟩
+  intro ty hty
+  have hty' : ty = dependentRecordType :=
+    List.mem_singleton.1 (by simpa [dependentRecordDecl] using hty)
+  subst ty
+  refine ⟨?_, ?_⟩
+  · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩
+  · intro c hc
+    have hc' : c = dependentRecordCtor := by
+      simpa [dependentRecordType] using hc
+    subst c
+    constructor
+    · simp [dependentRecordDecl, dependentRecordType,
+        dependentRecordCtor, VInductDecl.fieldsWF,
+        VInductDecl.ctorFields, VInductDecl.isRecField,
+        VInductDecl.recArg?, VInductDecl.recTarget?,
+        VInductDecl.recFieldIdxs, VInductDecl.sortLevel,
+        VExpr.dropN, VExpr.resultOf, VExpr.appHead,
+        VExpr.appArgs]
+      exact ⟨
+        ⟨VLevel.succ (.param 0), by type_tac, VLevel.le_max_left⟩,
+        ⟨VLevel.succ (.param 1), by type_tac, VLevel.le_max_right⟩⟩
+    · simp [dependentRecordDecl, dependentRecordType,
+        dependentRecordCtor, VInductDecl.ctorFields,
+        VInductDecl.recFieldIdxs, VInductDecl.sortLevel,
+        VExpr.dropN, VExpr.resultOf, VExpr.forallN,
+        VExpr.liftTelN, VExpr.appArgs]
+      exact .nil
+
+theorem dependentRecordGeneration_wf :
+    dependentRecordGeneration.WF VEnv.empty :=
+  (dependentRecordChecked.wf_of_decl
+    dependentRecordDecl_wf).identityGeneration .empty
+
+theorem dependentRecordEnv_ordered : dependentRecordEnv.Ordered :=
+  VEnv.addInductGeneration_WF .empty dependentRecordGeneration_wf
+    dependentRecord_add
+
+theorem dependentRecordEnv_wf : dependentRecordEnv.WF :=
+  ⟨[.induct dependentRecordDecl],
+    .decl (.induct dependentRecordGeneration_wf dependentRecord_add) .empty⟩
+
+theorem dependentRecord_generation_semantics :
+    dependentRecordView.GenerationSemantics dependentRecordEnv := by
+  rcases dependentRecord_trace with ⟨trace⟩
+  exact .ofGenerationTrace dependentRecordGeneration_wf trace
+
+theorem dependentRecord_registered :
+    dependentRecordView.Registered dependentRecordEnv := by
+  rcases dependentRecord_trace with ⟨trace⟩
+  refine {
+    family := trace.family_lookup
+    constructor := ?_
+    recursor := trace.rec_lookup
+    rules := fun _ h => trace.rule_mem h }
+  apply trace.ctor_lookup
+  rw [← dependentRecordGeneration.rawCtors_eq]
+  exact List.mem_map.2 ⟨dependentRecordView.constructor,
+    by
+      change dependentRecordView.constructor ∈
+        dependentRecordView.generation.block.ctorPairs
+      rw [dependentRecordView.constructor_eq]
+      simp,
+    rfl⟩
+
+theorem dependentRecord_view_wf :
+    dependentRecordView.WF dependentRecordEnv := by
+  refine {
+    toRegistered := dependentRecord_registered
+    generationSemantics := dependentRecord_generation_semantics
+    parameters := ?_
+    parameters_length := rfl
+    fieldTelescope := ?_
+    smallFields := ?_ }
+  · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩
+  · exact .cons (by type_tac) (.cons (by type_tac) .nil)
+  · intro h
+    change VInductDecl.ElimMode.large = .small at h
+    contradiction
+
+/-- The checked artifact retains both parameters and exactly the two
+dependent fields from the real kernel declaration. -/
+example : dependentRecordGeneration.block.rawParams =
+    [.sort (.succ (.param 0)),
+      .forallE (.bvar 0) (.sort (.succ (.param 1)))] := rfl
+
+example : dependentRecordView.fields =
+    [.bvar 1, .app (.bvar 1) (.bvar 0)] := rfl
+
+example : dependentRecordGeneration.elimination = .large := rfl
+
+private def permC (ci : VConstant) (levels : List VLevel) : VConstant :=
+  ⟨ci.uvars, ci.type.instL levels⟩
+
+example : dependentRecordGeneration.recursor =
+    permC (vconst(type_of% @DependentRecord.rec))
+      [.param 1, .param 2, .param 0] := rfl
+
+def symbolicLevels : List VLevel := [.param 0, .param 1]
+
+/-- Parameters in the context `[family, α]`, outermost first. -/
+def symbolicParams : List VExpr := [.bvar 1, .bvar 0]
+
+def symbolicStructureType : VExpr :=
+  dependentRecordView.structureType symbolicLevels symbolicParams
+
+example : dependentRecordView.specializedFields symbolicLevels symbolicParams =
+    [.bvar 1, .app (.bvar 1) (.bvar 0)] := rfl
+
+def keyCode : VStructureView.ProjectionCode :=
+  (dependentRecordView.projectionCodes symbolicLevels symbolicParams)[0]
+
+def valueCode : VStructureView.ProjectionCode :=
+  (dependentRecordView.projectionCodes symbolicLevels symbolicParams)[1]
+
+/-- Constructor reduction selects the first field for `key`. -/
+example : keyCode.minor =
+    .lam (.bvar 1)
+      (.lam (.app (.bvar 1) (.bvar 0)) (.bvar 1)) := rfl
+
+/-- Constructor reduction selects the second field for `value`. -/
+example : valueCode.minor =
+    .lam (.bvar 1)
+      (.lam (.app (.bvar 1) (.bvar 0)) (.bvar 0)) := rfl
+
+/-- The first field type is `α`. -/
+example : keyCode.typeFn =
+    .lam symbolicStructureType (.bvar 2) := rfl
+
+/-- The dependent second field type is `family (key major)`: the earlier
+projection program occurs in the later motive, rather than being supplied by
+an unconstrained witness. -/
+example : valueCode.typeFn =
+    .lam symbolicStructureType
+      (.app (.bvar 1) (.app keyCode.projector.lift (.bvar 0))) := rfl
+
+example : dependentRecordView.projectionLevels keyCode.fieldSort symbolicLevels =
+    [.succ (.param 0), .param 0, .param 1] := rfl
+
+example : dependentRecordView.projectionLevels valueCode.fieldSort symbolicLevels =
+    [.succ (.param 1), .param 0, .param 1] := rfl
+
+example : dependentRecordView.project? symbolicLevels symbolicParams 2 (.bvar 0) =
+    none := rfl
+
+/-- Eta reconstruction uses every generated projector in constructor-field
+order, including the projector whose motive depends on the earlier field. -/
+example : dependentRecordView.etaRebuild symbolicLevels symbolicParams
+    (.bvar 0) =
+      VExpr.appN (.const ``DependentRecord.mk symbolicLevels)
+        (symbolicParams ++
+          [.app keyCode.projector (.bvar 0),
+            .app valueCode.projector (.bvar 0)]) := rfl
+
+/-! A fully constrained `VEnv.TrProj` witness in a universe-polymorphic
+local context. -/
+
+def symbolicAlphaType : VExpr := .sort (.succ (.param 0))
+
+def symbolicFamilyType : VExpr :=
+  .forallE (.bvar 0) (.sort (.succ (.param 1)))
+
+/-- The major binder type is written over `[family, α]`. -/
+def symbolicMajorBinderType : VExpr :=
+  dependentRecordView.structureType symbolicLevels [.bvar 1, .bvar 0]
+
+def symbolicContext : List VExpr :=
+  [symbolicMajorBinderType, symbolicFamilyType, symbolicAlphaType]
+
+/-- The same parameters as seen under the major binder. -/
+def symbolicMajorParams : List VExpr := [.bvar 2, .bvar 1]
+
+def symbolicMajor : VExpr := .bvar 0
+
+theorem symbolicLevels_wf :
+    ∀ level ∈ symbolicLevels, level.WF 2 := by
+  simp [symbolicLevels, VLevel.WF]
+
+theorem symbolicParams_spine :
+    ∃ resultLevel, dependentRecordEnv.SpineWF 2 symbolicContext
+      (dependentRecordView.familyType.instL symbolicLevels)
+      symbolicMajorParams (.sort resultLevel) := by
+  refine ⟨.max (.succ (.param 0)) (.succ (.param 1)),
+    .cons (by type_tac) ?_⟩
+  exact .cons (by type_tac) .nil
+
+theorem symbolicMajor_hasType :
+    dependentRecordEnv.HasType 2 symbolicContext symbolicMajor
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams) := by
+  exact .bvar .zero
+
+def symbolicKeyCode : VStructureView.ProjectionCode :=
+  (dependentRecordView.projectionCodes symbolicLevels symbolicMajorParams)[0]
+
+def symbolicValueCode : VStructureView.ProjectionCode :=
+  (dependentRecordView.projectionCodes symbolicLevels symbolicMajorParams)[1]
+
+def symbolicFieldContext : List VExpr :=
+  [.app (.bvar 3) (.bvar 0), .bvar 3,
+    dependentRecordView.structureType symbolicLevels symbolicMajorParams] ++
+    symbolicContext
+
+def symbolicConstructorApp : VExpr :=
+  dependentRecordView.projectionConstructorApp symbolicLevels
+    (symbolicMajorParams.map (VExpr.liftN 1))
+    [.bvar 3, .app (.bvar 3) (.bvar 0)]
+
+def symbolicInnerStructureType : VExpr :=
+  dependentRecordView.structureType symbolicLevels [.bvar 5, .bvar 4]
+
+theorem symbolicConstructor_hasType :
+    dependentRecordEnv.HasType 2 symbolicFieldContext symbolicConstructorApp
+      symbolicInnerStructureType := by
+  have hc := VEnv.HasType.const
+    (Γ := symbolicFieldContext) dependentRecord_view_wf.constructor
+      symbolicLevels_wf (by rfl)
+  have hα : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 5) (.sort (.succ (.param 0))) := by
+    type_tac
+  have hFamily : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 4) (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by
+    type_tac
+  have hKey : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 1) (.bvar 5) := by
+    type_tac
+  have hValue : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by
+    type_tac
+  have hcα := hc.app hα
+  have hcFamily := hcα.app hFamily
+  have hcKey := hcFamily.app hKey
+  have hcValue := hcKey.app hValue
+  change dependentRecordEnv.HasType 2 symbolicFieldContext
+    symbolicConstructorApp symbolicInnerStructureType at hcValue
+  exact hcValue
+
+private def takeLamDomains : Nat → VExpr → List VExpr
+  | 0, _ => []
+  | n + 1, .lam A body => A :: takeLamDomains n body
+  | _ + 1, _ => []
+
+private def dropLamBody : Nat → VExpr → VExpr
+  | 0, e => e
+  | n + 1, .lam _ body => dropLamBody n body
+  | _ + 1, e => e
+
+private def dropForallBody : Nat → VExpr → VExpr
+  | 0, e => e
+  | n + 1, .forallE _ body => dropForallBody n body
+  | _ + 1, e => e
+
+theorem symbolicStructure_isType : dependentRecordEnv.IsType 2 symbolicContext
+    (dependentRecordView.structureType symbolicLevels symbolicMajorParams) := by
+  obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine
+  have hfamily := VEnv.HasType.const
+    (Γ := symbolicContext) dependentRecord_view_wf.family
+      symbolicLevels_wf (by rfl)
+  exact ⟨resultLevel, by
+    simpa [VStructureView.structureType] using hspine.hasType_appN hfamily⟩
+
+theorem symbolicMajorBinder_isType : dependentRecordEnv.IsType 2
+    [symbolicFamilyType, symbolicAlphaType] symbolicMajorBinderType := by
+  let resultLevel := VLevel.max (.succ (.param 0)) (.succ (.param 1))
+  have hspine : dependentRecordEnv.SpineWF 2
+      [symbolicFamilyType, symbolicAlphaType]
+      (dependentRecordView.familyType.instL symbolicLevels)
+      [.bvar 1, .bvar 0] (.sort resultLevel) := by
+    refine .cons (by type_tac) ?_
+    exact .cons (by type_tac) .nil
+  have hfamily := VEnv.HasType.const
+    (Γ := [symbolicFamilyType, symbolicAlphaType])
+      dependentRecord_view_wf.family symbolicLevels_wf (by rfl)
+  exact ⟨resultLevel, by
+    simpa [symbolicMajorBinderType, VStructureView.structureType] using
+      hspine.hasType_appN hfamily⟩
+
+theorem symbolicFieldContext_wf :
+    OnCtx symbolicFieldContext (dependentRecordEnv.IsType 2) := by
+  refine ⟨?_, ⟨_, by type_tac⟩⟩
+  refine ⟨?_, ⟨_, by type_tac⟩⟩
+  refine ⟨?_, symbolicStructure_isType⟩
+  refine ⟨?_, symbolicMajorBinder_isType⟩
+  refine ⟨?_, ⟨_, by type_tac⟩⟩
+  exact ⟨trivial, ⟨_, by type_tac⟩⟩
+
+def symbolicKeyMotive : VExpr := symbolicKeyCode.typeFn.liftN 3
+
+def symbolicKeyMinor : VExpr := symbolicKeyCode.minor.liftN 3
+
+def symbolicKeyRuleLevels : List VLevel :=
+  dependentRecordView.projectionLevels symbolicKeyCode.fieldSort symbolicLevels
+
+def symbolicKeyRule : VDefEq := dependentRecordGeneration.generatedRules[0]
+
+def symbolicKeyRuleType : VExpr :=
+  .forallE (.sort (.succ (.param 0)))
+    (.forallE (.forallE (.bvar 0) (.sort (.succ (.param 1))))
+      (.forallE
+        (.forallE
+          (dependentRecordView.structureType symbolicLevels [.bvar 1, .bvar 0])
+          (.sort (.succ (.param 0))))
+        (.forallE
+          (.forallE (.bvar 2)
+            (.forallE (.app (.bvar 2) (.bvar 0))
+              (.app (.bvar 2)
+                (.app
+                  (.app
+                    (.app
+                      (.app (.const ``DependentRecord.mk symbolicLevels)
+                        (.bvar 4))
+                      (.bvar 3))
+                    (.bvar 1))
+                  (.bvar 0)))))
+          (.forallE (.bvar 3)
+            (.forallE (.app (.bvar 3) (.bvar 0))
+              (.app (.bvar 3)
+                (.app
+                  (.app
+                    (.app
+                      (.app (.const ``DependentRecord.mk symbolicLevels)
+                        (.bvar 5))
+                      (.bvar 4))
+                    (.bvar 1))
+                  (.bvar 0))))))))
+
+theorem symbolicKeyRuleType_eq :
+    symbolicKeyRule.type.instL symbolicKeyRuleLevels =
+      symbolicKeyRuleType := rfl
+
+def symbolicKeyRuleArgs : List VExpr :=
+  [.bvar 5, .bvar 4, symbolicKeyMotive, symbolicKeyMinor,
+    .bvar 1, .bvar 0]
+
+def symbolicKeyRuleResult : VExpr :=
+  VExpr.instRev (dropForallBody 6 symbolicKeyRuleType) symbolicKeyRuleArgs
+
+theorem symbolicKeyRule_spine :
+    dependentRecordEnv.SpineWF 2 symbolicFieldContext
+      (symbolicKeyRule.type.instL symbolicKeyRuleLevels)
+      symbolicKeyRuleArgs symbolicKeyRuleResult := by
+  rw [symbolicKeyRuleType_eq]
+  unfold symbolicKeyRuleArgs symbolicKeyRuleResult
+  refine .cons (by type_tac) ?_
+  refine .cons (by type_tac) ?_
+  refine .cons ?_ ?_
+  · have hMotiveShape : symbolicKeyMotive =
+        .lam
+          ((dependentRecordView.structureType symbolicLevels
+            symbolicMajorParams).liftN 3)
+          (.bvar 6) := rfl
+    rw [hMotiveShape]
+    obtain ⟨structureLevel, hstructure⟩ :=
+      symbolicStructure_isType.weakN dependentRecordEnv_ordered
+        (Ctx.LiftN.zero
+          [.app (.bvar 3) (.bvar 0), .bvar 3,
+            dependentRecordView.structureType symbolicLevels
+              symbolicMajorParams])
+    exact VEnv.HasType.lam (u := structureLevel) hstructure (by type_tac)
+  · refine .cons ?_ ?_
+    · change dependentRecordEnv.HasType 2 symbolicFieldContext
+        symbolicKeyMinor
+        (.forallE (.bvar 5)
+          (.forallE (.app (.bvar 5) (.bvar 0))
+            (.app (symbolicKeyMotive.liftN 2)
+              (.app
+                (.app
+                  (.app
+                    (.app (.const ``DependentRecord.mk symbolicLevels)
+                      (.bvar 7))
+                    (.bvar 6))
+                  (.bvar 1))
+                (.bvar 0)))))
+      have hMinorShape : symbolicKeyMinor =
+          .lam (.bvar 5)
+            (.lam (.app (.bvar 5) (.bvar 0)) (.bvar 1)) := rfl
+      rw [hMinorShape]
+      refine .lam (by type_tac) ?_
+      refine .lam (by type_tac) ?_
+      have hMotiveLiftShape : symbolicKeyMotive.liftN 2 =
+          .lam
+            (dependentRecordView.structureType symbolicLevels
+              [.bvar 7, .bvar 6])
+            (.bvar 8) := rfl
+      rw [hMotiveLiftShape]
+      let innerCtor : VExpr :=
+        .app
+          (.app
+            (.app
+              (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 7))
+              (.bvar 6))
+            (.bvar 1))
+          (.bvar 0)
+      let innerStructure : VExpr :=
+        dependentRecordView.structureType symbolicLevels [.bvar 7, .bvar 6]
+      have hkey : dependentRecordEnv.HasType 2
+          ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+          (.bvar 1) (.bvar 7) := by
+        type_tac
+      have hctor : dependentRecordEnv.HasType 2
+          ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+          innerCtor innerStructure := by
+        have hc := VEnv.HasType.const
+          (Γ := ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 ::
+            symbolicFieldContext))
+          dependentRecord_view_wf.constructor symbolicLevels_wf (by rfl)
+        have hα : dependentRecordEnv.HasType 2
+            ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+            (.bvar 7) (.sort (.succ (.param 0))) := by
+          type_tac
+        have hFamily : dependentRecordEnv.HasType 2
+            ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+            (.bvar 6)
+            (.forallE (.bvar 7) (.sort (.succ (.param 1)))) := by
+          type_tac
+        have hValue : dependentRecordEnv.HasType 2
+            ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+            (.bvar 0) (.app (.bvar 6) (.bvar 1)) := by
+          type_tac
+        have hcValue := (((hc.app hα).app hFamily).app hkey).app hValue
+        change dependentRecordEnv.HasType 2
+          ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+          innerCtor innerStructure at hcValue
+        exact hcValue
+      have hbody : dependentRecordEnv.HasType 2
+          (innerStructure :: (.app (.bvar 5) (.bvar 0)) :: .bvar 5 ::
+            symbolicFieldContext)
+          (.bvar 8) (.sort (.succ (.param 0))) := by
+        dsimp [innerStructure]
+        type_tac
+      have hbetaRaw := VEnv.IsDefEq.beta hbody hctor
+      have hbeta : dependentRecordEnv.IsDefEq 2
+          ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext)
+          (.app (.lam innerStructure (.bvar 8)) innerCtor)
+          (.bvar 7) (.sort (.succ (.param 0))) := by
+        simpa [innerCtor, innerStructure, VExpr.inst, VExpr.instVar] using hbetaRaw
+      exact hbeta.symm.defeq hkey
+    · refine .cons (by type_tac) ?_
+      exact .cons (by type_tac) .nil
+
+def symbolicKeyRuleBinders : List VExpr :=
+  takeLamDomains 6 (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels)
+
+def symbolicKeyRuleLhsBody : VExpr :=
+  dropLamBody 6 (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels)
+
+def symbolicKeyRuleRhsBody : VExpr :=
+  dropLamBody 6 (symbolicKeyRule.rhs.instL symbolicKeyRuleLevels)
+
+def symbolicKeyRuleTypeBody : VExpr :=
+  dropForallBody 6 (symbolicKeyRule.type.instL symbolicKeyRuleLevels)
+
+theorem symbolicKeyRule_lhs_shape :
+    symbolicKeyRule.lhs.instL symbolicKeyRuleLevels =
+      VExpr.lamN symbolicKeyRuleBinders symbolicKeyRuleLhsBody := rfl
+
+theorem symbolicKeyRule_rhs_shape :
+    symbolicKeyRule.rhs.instL symbolicKeyRuleLevels =
+      VExpr.lamN symbolicKeyRuleBinders symbolicKeyRuleRhsBody := rfl
+
+theorem symbolicKeyRule_type_shape :
+    symbolicKeyRule.type.instL symbolicKeyRuleLevels =
+      VExpr.forallN symbolicKeyRuleBinders symbolicKeyRuleTypeBody := rfl
+
+theorem symbolicKeyRuleBinders_length : symbolicKeyRuleBinders.length = 6 := rfl
+
+theorem symbolicKeyRuleArgs_length : symbolicKeyRuleArgs.length = 6 := rfl
+
+theorem symbolicKeyRule_registered : dependentRecordEnv.defeqs symbolicKeyRule := by
+  apply dependentRecord_view_wf.rules
+  decide
+
+theorem symbolicKeyRule_levels_wf :
+    ∀ level ∈ symbolicKeyRuleLevels, level.WF 2 := by
+  decide
+
+theorem symbolicKeyRule_levels_length :
+    symbolicKeyRuleLevels.length = symbolicKeyRule.uvars := by
+  decide
+
+theorem symbolicKeyRule_reduces : dependentRecordEnv.IsDefEqU 2
+    symbolicFieldContext
+    (VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs)
+    (VExpr.instRev symbolicKeyRuleRhsBody symbolicKeyRuleArgs) := by
+  have hextra : dependentRecordEnv.IsDefEq 2 symbolicFieldContext
+      (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels)
+      (symbolicKeyRule.rhs.instL symbolicKeyRuleLevels)
+      (symbolicKeyRule.type.instL symbolicKeyRuleLevels) :=
+    .extra symbolicKeyRule_registered symbolicKeyRule_levels_wf
+      symbolicKeyRule_levels_length
+  have happlied := hextra.appN_congr symbolicKeyRule_spine
+  have hlhsType := hextra.hasType.1
+  rw [symbolicKeyRule_lhs_shape] at hlhsType
+  obtain ⟨hlhsTel, lhsType, hlhsBody⟩ := VEnv.HasType.lamN_wf
+    dependentRecordEnv_ordered symbolicFieldContext_wf hlhsType
+  have hlhsSpine := symbolicKeyRule_spine
+  rw [symbolicKeyRule_type_shape] at hlhsSpine
+  have hlhsRetarget := hlhsSpine.retarget
+    (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm)
+    lhsType
+  have hcollapseL := VEnv.IsDefEq.appN_lamN dependentRecordEnv_ordered
+    hlhsTel hlhsBody hlhsRetarget
+      (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm)
+  have hrhsType := hextra.hasType.2
+  rw [symbolicKeyRule_rhs_shape] at hrhsType
+  obtain ⟨hrhsTel, rhsType, hrhsBody⟩ := VEnv.HasType.lamN_wf
+    dependentRecordEnv_ordered symbolicFieldContext_wf hrhsType
+  have hrhsSpine := symbolicKeyRule_spine
+  rw [symbolicKeyRule_type_shape] at hrhsSpine
+  have hrhsRetarget := hrhsSpine.retarget
+    (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm)
+    rhsType
+  have hcollapseR := VEnv.IsDefEq.appN_lamN dependentRecordEnv_ordered
+    hrhsTel hrhsBody hrhsRetarget
+      (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm)
+  rw [symbolicKeyRule_lhs_shape, symbolicKeyRule_rhs_shape] at happlied
+  exact VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf
+    ⟨_, hcollapseL.symm⟩
+    (VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf
+      ⟨_, happlied⟩ ⟨_, hcollapseR⟩)
+
+theorem symbolicKeyProjector_hasType :
+    dependentRecordEnv.HasType 2 symbolicContext symbolicKeyCode.projector
+      (.forallE
+        (dependentRecordView.structureType symbolicLevels symbolicMajorParams)
+        (.app symbolicKeyCode.typeFn.lift (.bvar 0))) := by
+  obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine
+  have hfamily := VEnv.HasType.const
+    (Γ := symbolicContext) dependentRecord_view_wf.family
+      symbolicLevels_wf (by rfl)
+  have hstructure : dependentRecordEnv.HasType 2 symbolicContext
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams)
+      (.sort resultLevel) := by
+    simpa [VStructureView.structureType] using hspine.hasType_appN hfamily
+  have W : Ctx.LiftN 1 0 symbolicContext
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext) := .one
+  change dependentRecordEnv.HasType 2 symbolicContext (.lam _ _)
+    (.forallE _ _)
+  refine .lam hstructure ?_
+  change dependentRecordEnv.HasType 2
+    (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+      symbolicContext)
+    (VExpr.appN
+      (.const dependentRecordView.recursorName
+        (dependentRecordView.projectionLevels
+          symbolicKeyCode.fieldSort symbolicLevels))
+      (symbolicMajorParams.map (VExpr.liftN 1) ++
+        [symbolicKeyCode.typeFn.lift, symbolicKeyCode.minor.lift,
+          .bvar 0]))
+    (.app symbolicKeyCode.typeFn.lift (.bvar 0))
+  apply dependentRecord_view_wf.recursorProjection_hasType
+    dependentRecordEnv_ordered symbolicLevels symbolicLevels_wf rfl
+    (symbolicMajorParams.map (VExpr.liftN 1)) (by rfl)
+    (fieldSort := symbolicKeyCode.fieldSort)
+  · refine ⟨resultLevel, ?_⟩
+    have hfamilyClosed :
+        (dependentRecordView.familyType.instL symbolicLevels).ClosedN 0 := by
+      simpa using
+        (dependentRecordEnv_ordered.closedC
+          dependentRecord_view_wf.family).instL
+    have hspine' := hspine.weakN dependentRecordEnv_ordered W
+    rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine'
+    simpa [VExpr.liftN] using hspine'
+  · change VLevel.WF 2 (.succ (.param 0))
+    decide
+  · rfl
+  · exact ⟨resultLevel, by
+      simpa [VExpr.liftN] using hstructure.weakN dependentRecordEnv_ordered W⟩
+  · change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.lam
+        (dependentRecordView.structureType symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        (.bvar 4))
+      (.forallE
+        (dependentRecordView.structureType symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        (.sort (.succ (.param 0))))
+    refine VEnv.HasType.lam (u := resultLevel) ?_ (by type_tac)
+    simpa [VExpr.liftN] using
+      hstructure.weakN dependentRecordEnv_ordered W
+  · change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.lam (.bvar 3)
+        (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 1)))
+      (.forallE (.bvar 3)
+        (.forallE (.app (.bvar 3) (.bvar 0))
+          (.app
+            (.lam
+              (.app
+                (.app (.const ``DependentRecord symbolicLevels) (.bvar 5))
+                (.bvar 4))
+              (.bvar 6))
+            (.app
+              (.app
+                (.app
+                  (.app (.const ``DependentRecord.mk symbolicLevels)
+                    (.bvar 5))
+                  (.bvar 4))
+                (.bvar 1))
+              (.bvar 0)))))
+    refine .lam (by type_tac) ?_
+    refine .lam (by type_tac) ?_
+    have hkey : dependentRecordEnv.HasType 2
+        ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext)
+        (.bvar 1) (.bvar 5) := by
+      type_tac
+    apply (show dependentRecordEnv.IsDefEq 2
+      ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+        dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.bvar 5)
+      (.app
+        (.lam
+          (.app
+            (.app (.const ``DependentRecord symbolicLevels) (.bvar 5))
+            (.bvar 4))
+          (.bvar 6))
+        (.app
+          (.app
+            (.app
+              (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 5))
+              (.bvar 4))
+            (.bvar 1))
+          (.bvar 0)))
+      (.sort (.succ (.param 0))) from ?_).defeq hkey
+    let S : VExpr :=
+      .app
+        (.app (.const ``DependentRecord symbolicLevels) (.bvar 5))
+        (.bvar 4)
+    let ctorApp : VExpr :=
+      .app
+        (.app
+          (.app
+            (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 5))
+            (.bvar 4))
+          (.bvar 1))
+        (.bvar 0)
+    have hbody : dependentRecordEnv.HasType 2
+        (S :: (.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext)
+        (.bvar 6) (.sort (.succ (.param 0))) := by
+      dsimp [S]
+      type_tac
+    have hctor : dependentRecordEnv.HasType 2
+        ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext)
+        ctorApp S := by
+      have hc := VEnv.HasType.const
+        (Γ := ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext))
+        dependentRecord_view_wf.constructor symbolicLevels_wf (by rfl)
+      have hα : dependentRecordEnv.HasType 2
+          ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.bvar 5) (.sort (.succ (.param 0))) := by
+        type_tac
+      have hFamily : dependentRecordEnv.HasType 2
+          ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.bvar 4)
+          (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by
+        type_tac
+      have hKey : dependentRecordEnv.HasType 2
+          ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.bvar 1) (.bvar 5) := by
+        type_tac
+      have hValue : dependentRecordEnv.HasType 2
+          ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by
+        type_tac
+      have hcα := hc.app hα
+      have hcFamily := hcα.app hFamily
+      have hcKey := hcFamily.app hKey
+      have hcValue := hcKey.app hValue
+      change dependentRecordEnv.HasType 2
+        ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext)
+        ctorApp S at hcValue
+      exact hcValue
+    have hbeta := VEnv.IsDefEq.beta hbody hctor
+    simpa [S, ctorApp, VExpr.inst, VExpr.instVar] using hbeta.symm
+  · exact .bvar .zero
+
+def symbolicKeyProjectorBody : VExpr :=
+  match symbolicKeyCode.projector.liftN 3 with
+  | .lam _ body => body
+  | expression => expression
+
+theorem symbolicKeyProjector_lift_shape :
+    symbolicKeyCode.projector.liftN 3 =
+      .lam symbolicInnerStructureType symbolicKeyProjectorBody := by
+  decide
+
+theorem symbolicKeyProjector_beta_shape :
+    symbolicKeyProjectorBody.inst symbolicConstructorApp =
+      VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs := by
+  decide
+
+theorem symbolicKeyRule_rhs_result_shape :
+    VExpr.instRev symbolicKeyRuleRhsBody symbolicKeyRuleArgs =
+      .app (.app symbolicKeyMinor (.bvar 1)) (.bvar 0) := by
+  decide
+
+/-- The generated key projector computes on the generated constructor by
+the registered recursor iota rule. -/
+theorem symbolicKey_constructor_defeq : dependentRecordEnv.IsDefEq 2
+    symbolicFieldContext
+    (.app (symbolicKeyCode.projector.liftN 3) symbolicConstructorApp)
+    (.bvar 1) (.bvar 5) := by
+  have W3 : Ctx.LiftN 3 0 symbolicContext symbolicFieldContext :=
+    .zero [.app (.bvar 3) (.bvar 0), .bvar 3,
+      dependentRecordView.structureType symbolicLevels symbolicMajorParams]
+  have hprojector := symbolicKeyProjector_hasType.weakN
+    dependentRecordEnv_ordered W3
+  rw [symbolicKeyProjector_lift_shape] at hprojector
+  obtain ⟨_, ⟨projectorBodyType, hprojectorBody⟩⟩ :=
+    hprojector.lam_inv dependentRecordEnv_ordered symbolicFieldContext_wf
+  have hprojectorBeta := VEnv.IsDefEq.beta hprojectorBody
+    symbolicConstructor_hasType
+  rw [← symbolicKeyProjector_lift_shape,
+    symbolicKeyProjector_beta_shape] at hprojectorBeta
+  have hprojectorToRule : dependentRecordEnv.IsDefEqU 2
+      symbolicFieldContext
+      (.app (symbolicKeyCode.projector.liftN 3) symbolicConstructorApp)
+      (VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs) :=
+    ⟨projectorBodyType.inst symbolicConstructorApp, hprojectorBeta⟩
+
+  have houterBody : dependentRecordEnv.HasType 2
+      ((.bvar 5) :: symbolicFieldContext)
+      (.lam (.app (.bvar 5) (.bvar 0)) (.bvar 1))
+      (.forallE (.app (.bvar 5) (.bvar 0)) (.bvar 7)) := by
+    refine .lam (by type_tac) (by type_tac)
+  have hkey : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 1) (.bvar 5) := by
+    type_tac
+  have houterBeta := VEnv.IsDefEq.beta houterBody hkey
+  change dependentRecordEnv.IsDefEq 2 symbolicFieldContext
+    (.app symbolicKeyMinor (.bvar 1)) _ _ at houterBeta
+  have hvalue : dependentRecordEnv.HasType 2 symbolicFieldContext
+      (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by
+    type_tac
+  have houterApplied := VEnv.IsDefEq.appDF houterBeta hvalue
+  have hinnerBody : dependentRecordEnv.HasType 2
+      ((.app (.bvar 4) (.bvar 1)) :: symbolicFieldContext)
+      (.bvar 2) (.bvar 6) := by
+    type_tac
+  have hinnerBeta := VEnv.IsDefEq.beta hinnerBody hvalue
+  have hminorToKey := houterApplied.trans hinnerBeta
+  rw [← symbolicKeyRule_rhs_result_shape] at hminorToKey
+  have hresult := VEnv.IsDefEqU.trans dependentRecordEnv_wf
+    symbolicFieldContext_wf hprojectorToRule
+    (VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf
+      symbolicKeyRule_reduces ⟨_, hminorToKey⟩)
+  exact hresult.of_r dependentRecordEnv_wf symbolicFieldContext_wf hkey
+
+def symbolicValueTypeFnBody : VExpr :=
+  .app (.bvar 5)
+    (.app (symbolicKeyCode.projector.liftN 4) (.bvar 0))
+
+theorem symbolicValueTypeFn_lift_shape :
+    symbolicValueCode.typeFn.lift.liftN 2 =
+      .lam symbolicInnerStructureType symbolicValueTypeFnBody := by
+  decide
+
+theorem symbolicValueTypeFn_beta_shape :
+    symbolicValueTypeFnBody.inst symbolicConstructorApp =
+      .app (.bvar 4)
+        (.app (symbolicKeyCode.projector.liftN 3)
+          symbolicConstructorApp) := by
+  decide
+
+theorem symbolicValueTypeFnBody_hasType : dependentRecordEnv.HasType 2
+    (symbolicInnerStructureType :: symbolicFieldContext)
+    symbolicValueTypeFnBody (.sort (.succ (.param 1))) := by
+  have W4 : Ctx.LiftN 4 0 symbolicContext
+      (symbolicInnerStructureType :: symbolicFieldContext) :=
+    .zero [symbolicInnerStructureType,
+      .app (.bvar 3) (.bvar 0), .bvar 3,
+      dependentRecordView.structureType symbolicLevels symbolicMajorParams]
+  have hkeyProjector := symbolicKeyProjector_hasType.weakN
+    dependentRecordEnv_ordered W4
+  have hkeyAtMajor := hkeyProjector.app (VEnv.HasType.bvar (.zero))
+  change dependentRecordEnv.HasType 2
+    (symbolicInnerStructureType :: symbolicFieldContext) _
+    (.app
+      (.lam
+        (dependentRecordView.structureType symbolicLevels
+          [.bvar 6, .bvar 5])
+        (.bvar 7))
+      (.bvar 0)) at hkeyAtMajor
+  have hkeyBetaRaw : dependentRecordEnv.IsDefEq 2
+      (symbolicInnerStructureType :: symbolicFieldContext)
+      (.app
+        (.lam
+          (dependentRecordView.structureType symbolicLevels
+            [.bvar 6, .bvar 5])
+          (.bvar 7))
+        (.bvar 0))
+      ((VExpr.bvar 7).inst (.bvar 0))
+      ((VExpr.sort (.succ (.param 0))).inst (.bvar 0)) := by
+    apply VEnv.IsDefEq.beta
+    · type_tac
+    · exact .bvar .zero
+  have hkeyBeta : dependentRecordEnv.IsDefEq 2
+      (symbolicInnerStructureType :: symbolicFieldContext)
+      (.app
+        (.lam
+          (dependentRecordView.structureType symbolicLevels
+            [.bvar 6, .bvar 5])
+          (.bvar 7))
+        (.bvar 0))
+      (.bvar 6) (.sort (.succ (.param 0))) := by
+    simpa [VExpr.inst, VExpr.instVar] using hkeyBetaRaw
+  have hkeyAtMajor' := hkeyBeta.defeq hkeyAtMajor
+  have hfamily : dependentRecordEnv.HasType 2
+      (symbolicInnerStructureType :: symbolicFieldContext)
+      (.bvar 5)
+      (.forallE (.bvar 6) (.sort (.succ (.param 1)))) := by
+    type_tac
+  exact hfamily.app hkeyAtMajor'
+
+theorem symbolicValueProjector_hasType :
+    dependentRecordEnv.HasType 2 symbolicContext symbolicValueCode.projector
+      (.forallE
+        (dependentRecordView.structureType symbolicLevels symbolicMajorParams)
+        (.app symbolicValueCode.typeFn.lift (.bvar 0))) := by
+  obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine
+  have hfamily := VEnv.HasType.const
+    (Γ := symbolicContext) dependentRecord_view_wf.family
+      symbolicLevels_wf (by rfl)
+  have hstructure : dependentRecordEnv.HasType 2 symbolicContext
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams)
+      (.sort resultLevel) := by
+    simpa [VStructureView.structureType] using hspine.hasType_appN hfamily
+  have W : Ctx.LiftN 1 0 symbolicContext
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext) := .one
+  change dependentRecordEnv.HasType 2 symbolicContext (.lam _ _)
+    (.forallE _ _)
+  refine .lam hstructure ?_
+  change dependentRecordEnv.HasType 2
+    (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+      symbolicContext)
+    (VExpr.appN
+      (.const dependentRecordView.recursorName
+        (dependentRecordView.projectionLevels
+          symbolicValueCode.fieldSort symbolicLevels))
+      (symbolicMajorParams.map (VExpr.liftN 1) ++
+        [symbolicValueCode.typeFn.lift, symbolicValueCode.minor.lift,
+          .bvar 0]))
+    (.app symbolicValueCode.typeFn.lift (.bvar 0))
+  apply dependentRecord_view_wf.recursorProjection_hasType
+    dependentRecordEnv_ordered symbolicLevels symbolicLevels_wf rfl
+    (symbolicMajorParams.map (VExpr.liftN 1)) (by rfl)
+    (fieldSort := symbolicValueCode.fieldSort)
+  · refine ⟨resultLevel, ?_⟩
+    have hfamilyClosed :
+        (dependentRecordView.familyType.instL symbolicLevels).ClosedN 0 := by
+      simpa using
+        (dependentRecordEnv_ordered.closedC
+          dependentRecord_view_wf.family).instL
+    have hspine' := hspine.weakN dependentRecordEnv_ordered W
+    rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine'
+    simpa [VExpr.liftN] using hspine'
+  · change VLevel.WF 2 (.succ (.param 1))
+    decide
+  · rfl
+  · exact ⟨resultLevel, by
+      simpa [VExpr.liftN] using hstructure.weakN dependentRecordEnv_ordered W⟩
+  · change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      symbolicValueCode.typeFn.lift
+      (.forallE
+        (dependentRecordView.structureType symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        (.sort (.succ (.param 1))))
+    change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.lam
+        (dependentRecordView.structureType symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        (.app (.bvar 3)
+          (.app (symbolicKeyCode.projector.lift.liftN 1 1) (.bvar 0))))
+      (.forallE
+        (dependentRecordView.structureType symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        (.sort (.succ (.param 1))))
+    refine VEnv.HasType.lam (u := resultLevel) ?_ ?_
+    · simpa [VExpr.liftN] using
+        hstructure.weakN dependentRecordEnv_ordered W
+    · have Wbody : Ctx.LiftN 1 0
+          (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (dependentRecordView.structureType symbolicLevels
+              (symbolicMajorParams.map (VExpr.liftN 1)) ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext) := .one
+      have hkeyProjector :=
+        (symbolicKeyProjector_hasType.weakN dependentRecordEnv_ordered W).weakN
+          dependentRecordEnv_ordered Wbody
+      have hkeyAtMajor := hkeyProjector.app (VEnv.HasType.bvar (.zero))
+      have hkeyTypeFn : symbolicKeyCode.typeFn =
+          .lam
+            (dependentRecordView.structureType symbolicLevels symbolicMajorParams)
+            (.bvar 3) := rfl
+      rw [hkeyTypeFn] at hkeyAtMajor
+      change dependentRecordEnv.HasType 2
+        (dependentRecordView.structureType symbolicLevels
+            (symbolicMajorParams.map (VExpr.liftN 1)) ::
+          dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+          symbolicContext)
+        _
+        (.app
+          (.lam
+            (dependentRecordView.structureType symbolicLevels
+              [.bvar 4, .bvar 3])
+            (.bvar 5))
+          (.bvar 0)) at hkeyAtMajor
+      have hkeyBetaRaw : dependentRecordEnv.IsDefEq 2
+          (dependentRecordView.structureType symbolicLevels
+              (symbolicMajorParams.map (VExpr.liftN 1)) ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.app
+            (.lam
+              (dependentRecordView.structureType symbolicLevels
+                [.bvar 4, .bvar 3])
+              (.bvar 5))
+            (.bvar 0))
+          ((VExpr.bvar 5).inst (.bvar 0))
+          ((VExpr.sort (.succ (.param 0))).inst (.bvar 0)) := by
+        apply VEnv.IsDefEq.beta
+        · type_tac
+        · exact .bvar .zero
+      have hkeyBeta : dependentRecordEnv.IsDefEq 2
+          (dependentRecordView.structureType symbolicLevels
+              (symbolicMajorParams.map (VExpr.liftN 1)) ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.app
+            (.lam
+              (dependentRecordView.structureType symbolicLevels
+                [.bvar 4, .bvar 3])
+              (.bvar 5))
+            (.bvar 0))
+          (.bvar 4) (.sort (.succ (.param 0))) := by
+        simpa [VExpr.inst, VExpr.instVar] using hkeyBetaRaw
+      have hkeyAtMajor' := hkeyBeta.defeq hkeyAtMajor
+      have hprojectorLift :
+          VExpr.liftN 1 (VExpr.liftN 1 symbolicKeyCode.projector) =
+          symbolicKeyCode.projector.lift.liftN 1 1 := rfl
+      rw [hprojectorLift] at hkeyAtMajor'
+      have hfamilyAtMajor : dependentRecordEnv.HasType 2
+          (dependentRecordView.structureType symbolicLevels
+              (symbolicMajorParams.map (VExpr.liftN 1)) ::
+            dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+            symbolicContext)
+          (.bvar 3)
+          (.forallE (.bvar 4) (.sort (.succ (.param 1)))) := by
+        type_tac
+      exact hfamilyAtMajor.app hkeyAtMajor'
+  · change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.lam (.bvar 3)
+        (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 0)))
+      (dependentRecordView.projectionMinorType symbolicLevels
+        (symbolicMajorParams.map (VExpr.liftN 1))
+        (dependentRecordView.specializedFields symbolicLevels
+          (symbolicMajorParams.map (VExpr.liftN 1)))
+        symbolicValueCode.typeFn.lift)
+    have hfields : dependentRecordView.specializedFields symbolicLevels
+        (symbolicMajorParams.map (VExpr.liftN 1)) =
+        [.bvar 3, .app (.bvar 3) (.bvar 0)] := rfl
+    rw [hfields]
+    change dependentRecordEnv.HasType 2
+      (dependentRecordView.structureType symbolicLevels symbolicMajorParams ::
+        symbolicContext)
+      (.lam (.bvar 3)
+        (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 0)))
+      (.forallE (.bvar 3)
+        (.forallE (.app (.bvar 3) (.bvar 0))
+          (.app (symbolicValueCode.typeFn.lift.liftN 2)
+            (dependentRecordView.projectionConstructorApp symbolicLevels
+              (symbolicMajorParams.map (VExpr.liftN 1))
+              [.bvar 3, .app (.bvar 3) (.bvar 0)]))))
+    refine .lam (by type_tac) ?_
+    refine .lam (by type_tac) ?_
+    have htargetBeta := VEnv.IsDefEq.beta
+      symbolicValueTypeFnBody_hasType symbolicConstructor_hasType
+    rw [← symbolicValueTypeFn_lift_shape,
+      symbolicValueTypeFn_beta_shape] at htargetBeta
+    have hfamily : dependentRecordEnv.HasType 2 symbolicFieldContext
+        (.bvar 4)
+        (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by
+      type_tac
+    have htargetToNatural := htargetBeta.trans
+      (VEnv.IsDefEq.appDF hfamily symbolicKey_constructor_defeq)
+    have hvalue : dependentRecordEnv.HasType 2 symbolicFieldContext
+        (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by
+      type_tac
+    exact htargetToNatural.defeq' hvalue
+  · exact .bvar .zero
+
+def symbolicKeyResult : VExpr :=
+  .app symbolicKeyCode.projector symbolicMajor
+
+def symbolicValueResult : VExpr :=
+  .app symbolicValueCode.projector symbolicMajor
+
+theorem key_representable :
+    dependentRecordEnv.TrProj 2 symbolicContext dependentRecordView
+      symbolicLevels symbolicMajorParams 0 symbolicMajor symbolicKeyResult := by
+  refine {
+    viewWF := dependentRecord_view_wf
+    levelsWF := symbolicLevels_wf
+    levels_length := rfl
+    params_length := rfl
+    paramsSpine := symbolicParams_spine
+    majorType := symbolicMajor_hasType
+    program := ⟨symbolicKeyCode, rfl, rfl,
+      symbolicKeyProjector_hasType⟩ }
+
+theorem value_representable :
+    dependentRecordEnv.TrProj 2 symbolicContext dependentRecordView
+      symbolicLevels symbolicMajorParams 1 symbolicMajor symbolicValueResult := by
+  refine {
+    viewWF := dependentRecord_view_wf
+    levelsWF := symbolicLevels_wf
+    levels_length := rfl
+    params_length := rfl
+    paramsSpine := symbolicParams_spine
+    majorType := symbolicMajor_hasType
+    program := ⟨symbolicValueCode, rfl, rfl,
+      symbolicValueProjector_hasType⟩ }
+
+/-- The one generated iota equation used by both projection programs is
+actually registered in the final Theory environment. -/
+example : dependentRecordGeneration.generatedRules.length = 1 := rfl
+
+theorem dependentRecord_rules_registered :
+    ∀ rule ∈ dependentRecordGeneration.generatedRules,
+      dependentRecordEnv.defeqs rule :=
+  dependentRecord_view_wf.rules
+
+/-! ## Frozen legacy surface
+
+The seven fields below preserve the exact pre-L4L-13 theorem shapes.  They
+are intentionally only statement data: constructing this bundle would
+reintroduce the old proof obligations.  In particular, `wf` permits
+unrelated contexts, `uniq` permits unrelated structure names, and every
+field omits the environment, universe instantiation, and parameter spine. -/
+
+abbrev LegacyTrProj :=
+  List VExpr → Name → Nat → VExpr → VExpr → Prop
+
+structure LegacyProjectionLaws (R : LegacyTrProj) : Prop where
+  weak : ∀ {n Γ Γ' s i e e'},
+    Ctx.Lift' n Γ Γ' → R Γ s i e e' →
+      R Γ' s i (e.lift' n) (e'.lift' n)
+  inverseWeakening : ∀ {env U l Γ Γ' s i e e'},
+    VEnv.WF env → OnCtx Γ' (env.IsType U) → Ctx.Lift' l Γ Γ' →
+      R Γ' s i (e.lift' l) e' → ∃ result, R Γ s i e result
+  contextDefEq : ∀ {env U Γ₁ Γ₂ s i e₁ e₂ result},
+    VEnv.WF env → env.IsDefEqCtx U [] Γ₁ Γ₂ →
+      env.IsDefEqU U Γ₁ e₁ e₂ → R Γ₁ s i e₁ result →
+        ∃ result', R Γ₂ s i e₂ result'
+  wellFormed : ∀ {env U Δ Γ s i e result},
+    R Δ s i e result → VExpr.WF env U Γ e →
+      VExpr.WF env U Γ result
+  unique : ∀ {env U Γ₁ Γ₂ s₁ s₂ i e₁ e₂ result₁ result₂},
+    VEnv.WF env → env.IsDefEqCtx U [] Γ₁ Γ₂ →
+      R Γ₁ s₁ i e₁ result₁ → R Γ₂ s₂ i e₂ result₂ →
+        env.IsDefEqU U Γ₁ e₁ e₂ →
+          env.IsDefEqU U Γ₁ result₁ result₂
+  termSubstitution : ∀ {Γ₀ Γ₁ Γ s i e e' e₀ A₀ k},
+    Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ → R Γ₁ s i e e' →
+      R Γ s i (e.inst e₀ k) (e'.inst e₀ k)
+  universeInstantiation : ∀ {U' Γ s i e e'} {ls : List VLevel},
+    (∀ level ∈ ls, level.WF U') → R Γ s i e e' →
+      R (Γ.map (VExpr.instL ls)) s i (e.instL ls) (e'.instL ls)
+
+/-! ## Zero-field behavior -/
+
+universe w
+
+structure EmptyRecord (α : Type w) where
+
+def emptyRecordCtor : VConstVal :=
+  ⟨vconst(type_of% @EmptyRecord.mk), ``EmptyRecord.mk⟩
+
+def emptyRecordType : VInductiveType where
+  name := ``EmptyRecord
+  uvars := 1
+  type := vconst(type_of% @EmptyRecord).type
+  ctors := [emptyRecordCtor]
+
+def emptyRecordDecl : VInductDecl :=
+  ⟨1, 1, [emptyRecordType]⟩
+
+example : emptyRecordDecl.checked?.isSome = true := rfl
+
+def emptyRecordChecked : emptyRecordDecl.Checked :=
+  emptyRecordDecl.checked?.get (by decide)
+
+def emptyRecordGeneration : emptyRecordDecl.GenerationChecked :=
+  emptyRecordChecked.identityGeneration
+
+def emptyRecordView : VStructureView where
+  source := emptyRecordDecl
+  generation := emptyRecordGeneration
+  constructor := emptyRecordGeneration.block.ctorPairs[0]
+  constructor_eq := rfl
+  raw_indices_eq := rfl
+  checked_indices_eq := rfl
+  recursive_eq := rfl
+  fieldSorts := []
+  fieldSorts_length := rfl
+
+def emptyRecordEnv : VEnv :=
+  (VEnv.empty.addInductGeneration emptyRecordGeneration).get (by decide)
+
+theorem emptyRecord_add :
+    VEnv.empty.addInductGeneration emptyRecordGeneration =
+      some emptyRecordEnv := rfl
+
+theorem emptyRecord_trace :
+    Nonempty (VEnv.AddInductGenerationTrace VEnv.empty
+      emptyRecordEnv emptyRecordGeneration) :=
+  VEnv.addInductGeneration_trace emptyRecord_add
+
+theorem emptyRecordDecl_wf : emptyRecordDecl.WF VEnv.empty := by
+  refine ⟨rfl, ?_⟩
+  intro ty hty
+  have hty' : ty = emptyRecordType :=
+    List.mem_singleton.1 (by simpa [emptyRecordDecl] using hty)
+  subst ty
+  refine ⟨⟨⟨_, by type_tac⟩, trivial⟩, ?_⟩
+  intro c hc
+  have hc' : c = emptyRecordCtor := by
+    simpa [emptyRecordType] using hc
+  subst c
+  constructor
+  · simp [emptyRecordDecl, emptyRecordType, emptyRecordCtor,
+      VInductDecl.fieldsWF, VInductDecl.ctorFields,
+      VExpr.dropN]
+  · simp [emptyRecordDecl, emptyRecordType, emptyRecordCtor,
+      VInductDecl.ctorFields, VInductDecl.recFieldIdxs,
+      VInductDecl.sortLevel, VExpr.dropN, VExpr.resultOf,
+      VExpr.forallN, VExpr.liftTelN, VExpr.appArgs]
+    exact .nil
+
+theorem emptyRecordGeneration_wf :
+    emptyRecordGeneration.WF VEnv.empty :=
+  (emptyRecordChecked.wf_of_decl
+    emptyRecordDecl_wf).identityGeneration .empty
+
+theorem emptyRecord_generation_semantics :
+    emptyRecordView.GenerationSemantics emptyRecordEnv := by
+  rcases emptyRecord_trace with ⟨trace⟩
+  exact .ofGenerationTrace emptyRecordGeneration_wf trace
+
+theorem emptyRecord_registered : emptyRecordView.Registered emptyRecordEnv := by
+  rcases emptyRecord_trace with ⟨trace⟩
+  refine {
+    family := trace.family_lookup
+    constructor := ?_
+    recursor := trace.rec_lookup
+    rules := fun _ h => trace.rule_mem h }
+  apply trace.ctor_lookup
+  rw [← emptyRecordGeneration.rawCtors_eq]
+  exact List.mem_map.2 ⟨emptyRecordView.constructor,
+    by
+      change emptyRecordView.constructor ∈
+        emptyRecordView.generation.block.ctorPairs
+      rw [emptyRecordView.constructor_eq]
+      simp,
+    rfl⟩
+
+theorem emptyRecord_view_wf : emptyRecordView.WF emptyRecordEnv := by
+  refine {
+    toRegistered := emptyRecord_registered
+    generationSemantics := emptyRecord_generation_semantics
+    parameters := ⟨⟨_, by type_tac⟩, trivial⟩
+    parameters_length := rfl
+    fieldTelescope := .nil
+    smallFields := ?_ }
+  intro _ level hlevel
+  change level ∈ ([] : List VLevel) at hlevel
+  contradiction
+
+example : emptyRecordView.fields = [] := rfl
+
+example : emptyRecordView.projectionCodes [.param 0] [.bvar 0] = [] := rfl
+
+theorem emptyRecord_project_none (idx : Nat) (major : VExpr) :
+    emptyRecordView.project? [.param 0] [.bvar 0] idx major = none := by
+  simp [VStructureView.project?, show
+    emptyRecordView.projectionCodes [.param 0] [.bvar 0] = [] from rfl]
+
+/--
+info: 'Lean4Lean.Tests.ProjectionExpressibility.dependentRecord_view_wf' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms dependentRecord_view_wf
+
+/--
+info: 'Lean4Lean.Tests.ProjectionExpressibility.key_representable' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms key_representable
+
+/--
+info: 'Lean4Lean.Tests.ProjectionExpressibility.value_representable' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms value_representable
+
+/--
+info: 'Lean4Lean.Tests.ProjectionExpressibility.emptyRecord_project_none' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms emptyRecord_project_none
+
+end Lean4Lean.Tests.ProjectionExpressibility
diff --git a/Lean4Lean/Tests/StructureEtaCapability.lean b/Lean4Lean/Tests/StructureEtaCapability.lean
new file mode 100644
index 00000000..9f1047f1
--- /dev/null
+++ b/Lean4Lean/Tests/StructureEtaCapability.lean
@@ -0,0 +1,150 @@
+import Lean4Lean.Verify.TypeChecker.IsDefEq
+import Lean4Lean.Theory.Typing.ChurchRosser
+
+/-!
+# Registered structure-eta checker surface
+
+These guards pin the complete registered bridge. Host metadata resolves to
+the exact checked-view descriptor, subject reduction comes from its ordered
+registry certificate, and the primitive Theory rule closes both executable
+checker roots.
+-/
+
+namespace Lean4Lean.Tests.StructureEtaCapability
+
+open Lean4Lean.TypeChecker.Inner
+
+/-! ## Kernel eligibility and conversion matrix -/
+
+namespace Fixtures
+
+open Lean Elab Command
+
+elab "#guard_eta_eligible " n:ident : command => do
+  let env ← getEnv
+  unless Kernel.Environment.isNonRecStructure env.toKernelEnv n.getId do
+    throwError "expected {n.getId} to be structure-eta eligible"
+
+elab "#guard_eta_ineligible " n:ident : command => do
+  let env ← getEnv
+  if Kernel.Environment.isNonRecStructure env.toKernelEnv n.getId then
+    throwError "expected {n.getId} not to be structure-eta eligible"
+
+universe u v
+
+/-- Parameterized, dependent fields exercise the ordered projector spine. -/
+structure EtaDependent (α : Type u) (family : α → Type v) where
+  key : α
+  value : family key
+
+/-- The unit-like path is the empty projector-spine specialization. -/
+structure EtaEmpty (α : Type u) where
+
+/-- A proof field in a Type-valued structure remains eta eligible. -/
+structure EtaProofField (p : Prop) where
+  witness : p
+
+/-- Prop-valued structures share the same eligibility path. -/
+structure EtaProp (p : Prop) : Prop where
+  witness : p
+
+inductive EtaRecursive : Type where
+  | mk (tail : Option EtaRecursive)
+
+inductive EtaMulti : Type where
+  | left
+  | right
+
+inductive EtaIndexed : Bool → Type where
+  | mk : EtaIndexed true
+
+#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaDependent
+#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaEmpty
+#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaProofField
+#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaProp
+#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaRecursive
+#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaMulti
+#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaIndexed
+
+/-- Neutral-major reconstruction is kernel conversion, including dependence. -/
+example (x : EtaDependent α family) :
+    EtaDependent.mk x.key x.value = x := rfl
+
+example (x : EtaEmpty α) : EtaEmpty.mk = x := rfl
+
+example (x : EtaProofField p) : EtaProofField.mk x.witness = x := rfl
+
+example (x : EtaProp p) : EtaProp.mk x.witness = x := rfl
+
+end Fixtures
+
+#check VEnv.HasStructureEta
+#check VEnv.hasStructureEta_of_registry
+#check VStructEta.WF.rebuild_hasType
+#check VEnv.IsDefEq.structEta
+#check VEnv.IsDefEq.church_rosser
+#check StructureEtaArtifact
+#check StructureEtaReady
+#check tryEtaStructCore.WF_of_structureEta
+#check isDefEqUnitLike.WF_of_structureEta
+#check tryEtaStructCore.WF
+#check isDefEqUnitLike.WF
+
+/--
+info: 'Lean4Lean.VEnv.HasStructureEta' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.HasStructureEta
+
+/--
+info: 'Lean4Lean.VEnv.hasStructureEta_of_registry' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.hasStructureEta_of_registry
+
+/--
+info: 'Lean4Lean.VStructEta.WF.rebuild_hasType' depends on axioms: [propext]
+-/
+#guard_msgs in
+#print axioms VStructEta.WF.rebuild_hasType
+
+/--
+info: 'Lean4Lean.VEnv.IsDefEq.structEta' depends on axioms: [propext]
+-/
+#guard_msgs in
+#print axioms VEnv.IsDefEq.structEta
+
+/--
+info: 'Lean4Lean.VEnv.IsDefEq.church_rosser' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.IsDefEq.church_rosser
+
+/--
+info: 'Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.Expr.eqv_eq,
+ Lean.Level.instLawfulBEqLevel,
+ Lean.PersistentArray.toList'_push,
+ Lean.Syntax.structEq_eq,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert]
+-/
+#guard_msgs in
+#print axioms tryEtaStructCore.WF
+
+/--
+info: 'Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Lean.PersistentArray.toList'_push,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert]
+-/
+#guard_msgs in
+#print axioms isDefEqUnitLike.WF
+
+end Lean4Lean.Tests.StructureEtaCapability
diff --git a/Lean4Lean/Tests/TheoryConsumerSurface.lean b/Lean4Lean/Tests/TheoryConsumerSurface.lean
new file mode 100644
index 00000000..486050ed
--- /dev/null
+++ b/Lean4Lean/Tests/TheoryConsumerSurface.lean
@@ -0,0 +1,122 @@
+import Lean4Lean.Theory.Literals
+import Lean4Lean.Theory.Projection
+import Lean4Lean.Theory.Typing.InductiveLemmas
+import Lean4Lean.Theory.Typing.UniqueTyping
+
+/-!
+# Theory-only consumer surface
+
+This module deliberately imports no `Lean4Lean.Verify` module.  Name
+resolution here is the regression gate for the consumer-neutral declarations
+migrated by L4L-15C; the deprecated Verify aliases can therefore be removed
+without taking these APIs away from Theory consumers.
+-/
+
+namespace Lean4Lean.Tests.TheoryConsumerSurface
+
+#check VEnv.reflectedPrimitiveNames
+#check VEnv.HasPrimitives.of_avoids
+#check VEnv.addConst_other
+#check VEnv.HasPrimitives.addConst
+#check VExpr.WF.boolLit_has_type
+#check VExpr.hasConst_lift'
+#check VEnv.HasType.hasConst_false_of_absent
+#check VEnv.SpineWF.weak'
+#check VEnv.SpineWF.weakN_inv
+#check VEnv.SpineWF.weak'_inv
+#check VInductDecl.ElimMode.ofBool
+#check VStructureView.etaRebuild
+#check VStructureView.ProgramsWF.projectionArgsSpine
+#check VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix
+
+/--
+info: 'Lean4Lean.VEnv.reflectedPrimitiveNames' does not depend on any axioms
+-/
+#guard_msgs in
+#print axioms VEnv.reflectedPrimitiveNames
+
+/--
+info: 'Lean4Lean.VEnv.HasPrimitives.of_avoids' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.HasPrimitives.of_avoids
+
+/--
+info: 'Lean4Lean.VEnv.addConst_other' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.addConst_other
+
+/--
+info: 'Lean4Lean.VEnv.HasPrimitives.addConst' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.HasPrimitives.addConst
+
+/--
+info: 'Lean4Lean.VExpr.WF.boolLit_has_type' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VExpr.WF.boolLit_has_type
+
+/--
+info: 'Lean4Lean.VExpr.hasConst_lift'' depends on axioms: [propext]
+-/
+#guard_msgs in
+#print axioms VExpr.hasConst_lift'
+
+/--
+info: 'Lean4Lean.VEnv.HasType.hasConst_false_of_absent' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.HasType.hasConst_false_of_absent
+
+/--
+info: 'Lean4Lean.VEnv.SpineWF.weak'' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.SpineWF.weak'
+
+/--
+info: 'Lean4Lean.VEnv.SpineWF.weakN_inv' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.SpineWF.weakN_inv
+
+/--
+info: 'Lean4Lean.VEnv.SpineWF.weak'_inv' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.SpineWF.weak'_inv
+
+/--
+info: 'Lean4Lean.VInductDecl.ElimMode.ofBool' does not depend on any axioms
+-/
+#guard_msgs in
+#print axioms VInductDecl.ElimMode.ofBool
+
+/--
+info: 'Lean4Lean.VStructureView.etaRebuild' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VStructureView.etaRebuild
+
+/--
+info: 'Lean4Lean.VStructureView.ProgramsWF.projectionArgsSpine' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms VStructureView.ProgramsWF.projectionArgsSpine
+
+/--
+info: 'Lean4Lean.VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix
+
+end Lean4Lean.Tests.TheoryConsumerSurface
diff --git a/Lean4Lean/Tests/Toolchain.lean b/Lean4Lean/Tests/Toolchain.lean
index 47d10f38..9254cbe4 100644
--- a/Lean4Lean/Tests/Toolchain.lean
+++ b/Lean4Lean/Tests/Toolchain.lean
@@ -9,7 +9,7 @@ theorem theoremDelta : True := trivial
 theorem proofOnlyDependency : True := trivial
 theorem dependencyOnlyInProof : True := proofOnlyDependency
 
-def stringProof (_ : String) : True := trivial
+theorem stringProof (_ : String) : True := trivial
 theorem stringOnlyInProof : True := stringProof "audit"
 
 run_meta
diff --git a/Lean4Lean/Theory.lean b/Lean4Lean/Theory.lean
index 67c3c0f5..2a063b5c 100644
--- a/Lean4Lean/Theory.lean
+++ b/Lean4Lean/Theory.lean
@@ -1,5 +1,9 @@
 import Lean4Lean.Theory.Typing.EnvLemmas
+import Lean4Lean.Theory.Typing.InductiveCertificate
 import Lean4Lean.Theory.Typing.Strong
 import Lean4Lean.Theory.Typing.UniqueTyping
 import Lean4Lean.Theory.Typing.ChurchRosser
 import Lean4Lean.Theory.Typing.HeadReduction
+import Lean4Lean.Theory.LocalContext
+import Lean4Lean.Theory.Literals
+import Lean4Lean.Theory.Projection
diff --git a/Lean4Lean/Theory/Inductive.lean b/Lean4Lean/Theory/Inductive.lean
index 66a7bb1b..24f876e0 100644
--- a/Lean4Lean/Theory/Inductive.lean
+++ b/Lean4Lean/Theory/Inductive.lean
@@ -33,9 +33,13 @@ def VExpr.hasConst (n : Name) : VExpr → Bool
   | .const c _ => c == n
   | .app e1 e2 | .lam e1 e2 | .forallE e1 e2 => e1.hasConst n || e2.hasConst n
 
-def VExpr.appN (f : VExpr) : List VExpr → VExpr
-  | [] => f
-  | a :: as => (f.app a).appN as
+/-- Context lifting changes only bound-variable indices and therefore
+preserves the constants occurring in a Theory expression. -/
+@[simp] theorem VExpr.hasConst_lift' (expression : VExpr) (lift : Lift)
+    (name : Name) :
+    (expression.lift' lift).hasConst name = expression.hasConst name := by
+  induction expression generalizing lift <;>
+    simp [VExpr.hasConst, *]
 
 /-- `[.bvar (off+m-1), ..., .bvar off]`: the spine referring to the last `m`
 binders, skipping the innermost `off`. -/
@@ -109,16 +113,6 @@ def VEnv.TelDefEq (env : VEnv) (U : Nat) :
       TelDefEq env U (A :: Γ) As As'
   | _, _, _ => False
 
-/-- Typing of an application spine against an iterated pi type: peeling the
-expressions of `es` off `A` one instantiation at a time ends at `B`. This is
-the pointwise typing evidence for index spines; `addInduct_WF` consumes it
-wherever a recursive field or a constructor result applies the block to
-index arguments. -/
-def VEnv.SpineWF (env : VEnv) (U : Nat) (Γ : List VExpr) : VExpr → List VExpr → VExpr → Prop
-  | A, [], B => A = B
-  | A, e :: es, B => ∃ A₁ A₂, A = .forallE A₁ A₂ ∧ env.HasType U Γ e A₁ ∧
-    SpineWF env U Γ (A₂.inst e) es B
-
 namespace VInductDecl
 
 variable (U : Nat) (T : Name) (np : Nat)
@@ -650,6 +644,15 @@ inductive ElimMode where
   | small
   deriving DecidableEq, Repr
 
+/-- Interpret the ordinary checker's Boolean large-elimination result in the
+consumer-neutral Theory representation. -/
+def ElimMode.ofBool : Bool → ElimMode
+  | false => .small
+  | true => .large
+
+@[simp] theorem ElimMode.ofBool_false : ElimMode.ofBool false = .small := rfl
+@[simp] theorem ElimMode.ofBool_true : ElimMode.ofBool true = .large := rfl
+
 /-- Universe-slot offset used by recursor metadata. Large elimination inserts
 the fresh motive universe before the declaration universes; small elimination
 adds no universe parameter. -/
diff --git a/Lean4Lean/Theory/InductiveFixtures.lean b/Lean4Lean/Theory/InductiveFixtures.lean
index 2a85a300..5e07b842 100644
--- a/Lean4Lean/Theory/InductiveFixtures.lean
+++ b/Lean4Lean/Theory/InductiveFixtures.lean
@@ -186,8 +186,7 @@ theorem punitDecl_wf : punitDecl.WF VEnv.empty := by
     constructor
     · change True
       trivial
-    · change VExpr.sort (.param 0) = VExpr.sort (.param 0)
-      rfl
+    · exact .nil
 
 def punitEnv : VEnv :=
   (VEnv.empty.addInduct punitDecl).get (by decide)
@@ -626,7 +625,7 @@ theorem accDecl_wf : accDecl.WF VEnv.empty := by
                   (.forallE (.bvar 4) (.sort .zero)) [.bvar 1] (.sort .zero)
             constructor
             · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩
-            · exact ⟨_, _, rfl, by type_tac, rfl⟩
+            · exact .cons (by type_tac) .nil
         · intro h
           change false = true at h
           contradiction
@@ -639,7 +638,7 @@ theorem accDecl_wf : accDecl.WF VEnv.empty := by
           .forallE (.bvar 0) (.forallE (.bvar 1) (.sort .zero)),
           .sort (.param 0)]
         (.forallE (.bvar 3) (.sort .zero)) [.bvar 1] (.sort .zero)
-      exact ⟨_, _, rfl, by type_tac, rfl⟩
+      exact .cons (by type_tac) .nil
 
 /-- The concrete public Acc transaction preserves environment order. -/
 def accEnv : VEnv := (VEnv.empty.addInduct accDecl).get (by decide)
@@ -792,14 +791,14 @@ theorem annotatedPiViewDecl_wf : annotatedPiViewDecl.WF VEnv.empty := by
       refine ⟨annotatedPiRecArg, ?_, ?_, ?_⟩
       · rfl
       · simp [annotatedPiRecArg]
-      · exact ⟨⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩, rfl⟩
+      · exact ⟨⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩, .nil⟩
     · intro h
       change false = true at h
       contradiction
   · change VEnv.empty.SpineWF 0
       [.forallE (.sort .zero) (.const ``AnnotatedPi [])]
       (.sort (.succ .zero)) [] (.sort (.succ .zero))
-    rfl
+    exact .nil
 
 theorem annotatedPiViewChecked_wf :
     annotatedPiViewChecked.WF outParamEnv := by
@@ -933,7 +932,7 @@ theorem annotatedParamViewDecl_wf :
       List.mem_singleton.1 (by
         simpa [annotatedParamViewType] using hc)
     subst c
-    exact ⟨trivial, rfl⟩
+    exact ⟨trivial, .nil⟩
 
 /-- Exact Theory environment after staging the stored family constant. -/
 def annotatedParamTypeEnv : VEnv :=
@@ -1210,7 +1209,7 @@ theorem aliasFormerViewDecl_wf :
       List.mem_singleton.1 (by
         simpa [aliasFormerViewType, aliasFormerRawType] using hc)
     subst c
-    exact ⟨trivial, rfl⟩
+    exact ⟨trivial, .nil⟩
 
 /-- The paired block carries both the semantic normalization certificate and
 the checked normalized view required by downstream generation. -/
@@ -1567,8 +1566,8 @@ theorem aliasRecViewDecl_wf : aliasRecViewDecl.WF recAliasEnv := by
     have hc' : c = aliasRecViewCtor :=
       List.mem_singleton.1 (by simpa [aliasRecViewType] using hc)
     subst c
-    refine ⟨?_, rfl⟩
-    exact ⟨.inl rfl, fun _ => rfl, trivial⟩
+    refine ⟨?_, .nil⟩
+    exact ⟨.inl rfl, fun _ => .nil, trivial⟩
 
 /-- Recursive-field recognition is certified on the normalized view while the
 paired block continues to retain the raw aliased constructor syntax. -/
@@ -1982,11 +1981,11 @@ theorem normalizationMatrixPiAliasEnv_ordered :
               intro ls
               simp only [VLevel.eval, Nat.zero_add]
               let n := ls.getD 0 0
-              change Nat.imax 1 n = n
+              change Lean.Nat.imax 1 n = n
               by_cases h : n = 0
-              · simp [Nat.imax, h]
+              · simp [Lean.Nat.imax, h]
               · have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr h
-                simp [Nat.imax, h, Nat.max_eq_right hn]))
+                simp [Lean.Nat.imax, h, Nat.max_eq_right hn]))
         exact VEnv.HasType.forallE
           (VEnv.HasType.sort (by decide))
           (VEnv.HasType.bvar (.succ .zero))
@@ -2153,11 +2152,11 @@ private theorem normalizationMatrix_one_imax_equiv (u : VLevel) :
   intro ls
   simp only [VLevel.eval, Nat.zero_add]
   let n := u.eval ls
-  change Nat.imax 1 n = n
+  change Lean.Nat.imax 1 n = n
   by_cases h : n = 0
-  · simp [Nat.imax, h]
+  · simp [Lean.Nat.imax, h]
   · have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr h
-    simp [Nat.imax, h, Nat.max_eq_right hn]
+    simp [Lean.Nat.imax, h, Nat.max_eq_right hn]
 
 theorem normalizationMatrixPiAlias_app_defeq {env : VEnv} {U : Nat}
     {Γ : List VExpr} {u : VLevel} {A : VExpr} (hu : u.WF U)
@@ -2348,33 +2347,33 @@ theorem normalizationMatrixViewChecked_wf :
             · refine ⟨?_, ?_, ?_⟩
               · exact .inl rfl
               · intro _
-                exact ⟨_, _, rfl,
-                  normalizationMatrixIndexAlias_app_hasType .rfl
-                    (by type_tac), rfl⟩
+                exact .cons
+                  (normalizationMatrixIndexAlias_app_hasType .rfl
+                    (by type_tac)) .nil
               · refine ⟨?_, ?_, ?_⟩
                 · refine .inr (.inl ⟨_, rfl, by decide, ?_⟩)
                   constructor
                   · exact ⟨⟨_, by type_tac⟩, trivial⟩
-                  · exact ⟨_, _, rfl,
-                      normalizationMatrixIndexAlias_app_hasType .rfl
-                        (by type_tac), rfl⟩
+                  · exact .cons
+                      (normalizationMatrixIndexAlias_app_hasType .rfl
+                        (by type_tac)) .nil
                 · intro h
                   change false = true at h
                   contradiction
                 · refine ⟨?_, ?_, ?_⟩
                   · exact .inl rfl
                   · intro _
-                    exact ⟨_, _, rfl,
-                      normalizationMatrixIndexAlias_app_hasType .rfl
-                        (by type_tac), rfl⟩
+                    exact .cons
+                      (normalizationMatrixIndexAlias_app_hasType .rfl
+                        (by type_tac)) .nil
                   · refine ⟨?_, ?_, trivial⟩
                     · exact .inl rfl
                     · intro _
-                      exact ⟨_, _, rfl,
-                        normalizationMatrixIndexAlias_app_hasType .rfl
-                          (by type_tac), rfl⟩
-    · exact ⟨_, _, rfl,
-        normalizationMatrixIndexAlias_app_hasType .rfl (by type_tac), rfl⟩
+                      exact .cons
+                        (normalizationMatrixIndexAlias_app_hasType .rfl
+                          (by type_tac)) .nil
+    · exact .cons
+        (normalizationMatrixIndexAlias_app_hasType .rfl (by type_tac)) .nil
 
 theorem normalizationMatrixBlock_wf :
     normalizationMatrixBlock.WF normalizationMatrixAliasEnv :=
diff --git a/Lean4Lean/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean
new file mode 100644
index 00000000..e97daaae
--- /dev/null
+++ b/Lean4Lean/Theory/Literals.lean
@@ -0,0 +1,689 @@
+import Lean4Lean.Theory.Inductive
+import Lean4Lean.Theory.Typing.Strong
+
+/-! # Theory encodings of Lean literals and primitive reflection
+
+This file contains only `VExpr`/`VEnv` semantics.  Traversal of `Lean.Expr`
+and `Literal.toConstructor` belongs to the Verify translation layer.
+-/
+
+namespace Lean4Lean
+open Lean
+
+def VEnv.ContainsLits (env : VEnv) : Literal → Prop
+  | .natVal _ => env.contains ``Nat
+  | .strVal _ => env.contains ``Char.ofNat ∧ env.contains ``String.ofList
+
+def VExpr.bool : VExpr := .const ``Bool []
+def VExpr.boolTrue : VExpr := .const ``Bool.true []
+def VExpr.boolFalse : VExpr := .const ``Bool.false []
+def VExpr.boolLit : Bool → VExpr
+  | .false => .boolFalse
+  | .true => .boolTrue
+
+def VExpr.nat : VExpr := .const ``Nat []
+def VExpr.natZero : VExpr := .const ``Nat.zero []
+def VExpr.natSucc : VExpr := .const ``Nat.succ []
+def VExpr.natLit : Nat → VExpr
+  | 0 => .natZero
+  | n+1 => .app .natSucc (.natLit n)
+
+def VExpr.char : VExpr := .const ``Char []
+def VExpr.string : VExpr := .const ``String []
+def VExpr.stringOfList : VExpr := .const ``String.ofList []
+def VExpr.listChar : VExpr := .app (.const ``List [.zero]) .char
+def VExpr.listCharNil : VExpr := .app (.const ``List.nil [.zero]) .char
+def VExpr.listCharCons : VExpr := .app (.const ``List.cons [.zero]) .char
+def VExpr.charOfNat : VExpr := .const ``Char.ofNat []
+def VExpr.listCharLit : List Char → VExpr
+  | [] => .listCharNil
+  | a :: as =>
+    .app (.app .listCharCons (.app .charOfNat (.natLit a.toNat))) (.listCharLit as)
+
+def VExpr.trLiteral : Literal → VExpr
+  | .natVal n => .natLit n
+  | .strVal s => .app .stringOfList (.listCharLit s.toList)
+
+def VExpr.literalType : Literal → VExpr
+  | .natVal _ => .nat
+  | .strVal _ => .string
+
+/-! ## Exact prelude artifacts
+
+`ContainsLits` deliberately records only name occurrence.  The declarations
+below describe the exact Theory artifacts that make those names meaningful.
+The inductive recursors and iota rules are generated by the same
+consumer-neutral Theory machinery used by `VEnv.addInduct`.
+-/
+
+namespace LiteralPrelude
+
+def boolFalse : VConstVal :=
+  { name := ``Bool.false, uvars := 0, type := .bool }
+
+def boolTrue : VConstVal :=
+  { name := ``Bool.true, uvars := 0, type := .bool }
+
+def boolType : VInductiveType where
+  name := ``Bool
+  uvars := 0
+  type := .sort (.succ .zero)
+  ctors := [boolFalse, boolTrue]
+
+def boolRec : VConstant := VInductDecl.recConst 0 ``Bool 0 boolType
+def boolIotas : List VDefEq := VInductDecl.rules 0 ``Bool 0 boolType
+
+def natZero : VConstVal :=
+  { name := ``Nat.zero, uvars := 0, type := .nat }
+
+def natSucc : VConstVal :=
+  { name := ``Nat.succ, uvars := 0, type := .forallE .nat .nat }
+
+def natType : VInductiveType where
+  name := ``Nat
+  uvars := 0
+  type := .sort (.succ .zero)
+  ctors := [natZero, natSucc]
+
+def natRec : VConstant := VInductDecl.recConst 0 ``Nat 0 natType
+def natIotas : List VDefEq := VInductDecl.rules 0 ``Nat 0 natType
+
+def char : VConstant := { uvars := 0, type := .sort (.succ .zero) }
+def charOfNat : VConstant := { uvars := 0, type := .forallE .nat .char }
+
+def listNil : VConstVal where
+  name := ``List.nil
+  uvars := 1
+  type := .forallE (.sort (.succ (.param 0)))
+    (.app (.const ``List [.param 0]) (.bvar 0))
+
+def listCons : VConstVal where
+  name := ``List.cons
+  uvars := 1
+  type := .forallE (.sort (.succ (.param 0))) <|
+    .forallE (.bvar 0) <|
+      .forallE (.app (.const ``List [.param 0]) (.bvar 1))
+        (.app (.const ``List [.param 0]) (.bvar 2))
+
+def listType : VInductiveType where
+  name := ``List
+  uvars := 1
+  type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+  ctors := [listNil, listCons]
+
+def listRec : VConstant := VInductDecl.recConst 1 ``List 1 listType
+def listIotas : List VDefEq := VInductDecl.rules 1 ``List 1 listType
+
+def string : VConstant := { uvars := 0, type := .sort (.succ .zero) }
+def stringOfList : VConstant :=
+  { uvars := 0, type := .forallE .listChar .string }
+
+end LiteralPrelude
+
+/-- The exact kernel-facing prelude fragment needed to interpret Theory
+literals.  In contrast with `ContainsLits`, this records declaration types,
+recursors, iota rules, and an ordered construction history. -/
+structure VEnv.PreludeReady (env : VEnv) : Prop where
+  ordered : env.Ordered
+  bool : env.constants ``Bool = some LiteralPrelude.boolType.toVConstant
+  boolFalse : env.constants ``Bool.false =
+    some LiteralPrelude.boolFalse.toVConstant
+  boolTrue : env.constants ``Bool.true =
+    some LiteralPrelude.boolTrue.toVConstant
+  boolRec : env.constants ``Bool.rec = some LiteralPrelude.boolRec
+  boolIotas : ∀ df ∈ LiteralPrelude.boolIotas, env.defeqs df
+  nat : env.constants ``Nat = some LiteralPrelude.natType.toVConstant
+  natZero : env.constants ``Nat.zero =
+    some LiteralPrelude.natZero.toVConstant
+  natSucc : env.constants ``Nat.succ =
+    some LiteralPrelude.natSucc.toVConstant
+  natRec : env.constants ``Nat.rec = some LiteralPrelude.natRec
+  natIotas : ∀ df ∈ LiteralPrelude.natIotas, env.defeqs df
+  char : env.constants ``Char = some LiteralPrelude.char
+  charOfNat : env.constants ``Char.ofNat = some LiteralPrelude.charOfNat
+  list : env.constants ``List = some LiteralPrelude.listType.toVConstant
+  listNil : env.constants ``List.nil =
+    some LiteralPrelude.listNil.toVConstant
+  listCons : env.constants ``List.cons =
+    some LiteralPrelude.listCons.toVConstant
+  listRec : env.constants ``List.rec = some LiteralPrelude.listRec
+  listIotas : ∀ df ∈ LiteralPrelude.listIotas, env.defeqs df
+  string : env.constants ``String = some LiteralPrelude.string
+  stringOfList : env.constants ``String.ofList = some LiteralPrelude.stringOfList
+
+namespace VEnv.PreludeReady
+
+/-- Exact prelude artifacts transport across environment inclusion.  The
+target ordering premise is necessary because arbitrary `VEnv.LE` growth may
+append an ill-typed declaration. -/
+theorem mono {env env' : VEnv} (H : env.PreludeReady) (henv : env ≤ env')
+    (hordered : env'.Ordered) : env'.PreludeReady where
+  ordered := hordered
+  bool := henv.constants H.bool
+  boolFalse := henv.constants H.boolFalse
+  boolTrue := henv.constants H.boolTrue
+  boolRec := henv.constants H.boolRec
+  boolIotas := fun df hdf => henv.defeqs (H.boolIotas df hdf)
+  nat := henv.constants H.nat
+  natZero := henv.constants H.natZero
+  natSucc := henv.constants H.natSucc
+  natRec := henv.constants H.natRec
+  natIotas := fun df hdf => henv.defeqs (H.natIotas df hdf)
+  char := henv.constants H.char
+  charOfNat := henv.constants H.charOfNat
+  list := henv.constants H.list
+  listNil := henv.constants H.listNil
+  listCons := henv.constants H.listCons
+  listRec := henv.constants H.listRec
+  listIotas := fun df hdf => henv.defeqs (H.listIotas df hdf)
+  string := henv.constants H.string
+  stringOfList := henv.constants H.stringOfList
+
+/-- Any successful well-formed constant insertion preserves readiness.  It is
+necessarily unrelated to the ready prelude: all of those names are already
+occupied, while `addConst` succeeds only at a fresh name. -/
+theorem addConst {env env' : VEnv} (H : env.PreludeReady)
+    (hci : ci.WF env) (hadd : env.addConst name ci = some env') :
+    env'.PreludeReady :=
+  H.mono (VEnv.addConst_le hadd) (.const H.ordered hci hadd)
+
+/-- Adding a well-formed unrelated definitional equation preserves prelude
+readiness. -/
+theorem addDefEq {env : VEnv} (H : env.PreludeReady) (hdf : df.WF env) :
+    (env.addDefEq df).PreludeReady :=
+  H.mono VEnv.addDefEq_le (.defeq H.ordered hdf)
+
+/-- A ready prelude contains every name used by the direct literal encoding. -/
+theorem containsLits {env : VEnv} (H : env.PreludeReady) :
+    ∀ l, env.ContainsLits l
+  | .natVal _ => ⟨_, H.nat⟩
+  | .strVal _ => ⟨⟨_, H.charOfNat⟩, ⟨_, H.stringOfList⟩⟩
+
+end VEnv.PreludeReady
+
+def VEnv.ReflectsNatNatNat (env : VEnv) (fc : Name) (f : Nat → Nat → Nat) :=
+  env.contains fc →
+  ∀ a b, env.IsDefEqU 0 []
+    (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.natLit (f a b))
+
+def VEnv.ReflectsNatNatBool (env : VEnv) (fc : Name) (f : Nat → Nat → Bool) :=
+  env.contains fc →
+  ∀ a b, env.IsDefEqU 0 []
+    (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.boolLit (f a b))
+
+structure VEnv.HasPrimitives (env : VEnv) : Prop where
+  bool : env.contains ``Bool → env.contains ``Bool.false ∧ env.contains ``Bool.true
+  boolFalse : env.constants ``Bool.false = some ci → ci = { uvars := 0, type := .bool }
+  boolTrue : env.constants ``Bool.true = some ci → ci = { uvars := 0, type := .bool }
+  nat : env.contains ``Nat → env.contains ``Nat.zero ∧ env.contains ``Nat.succ
+  natZero : env.constants ``Nat.zero = some ci → ci = { uvars := 0, type := .nat }
+  natSucc : env.constants ``Nat.succ = some ci →
+    ci = { uvars := 0, type := .forallE .nat .nat }
+  natAdd : env.ReflectsNatNatNat ``Nat.add Nat.add
+  natSub : env.ReflectsNatNatNat ``Nat.sub Nat.sub
+  natMul : env.ReflectsNatNatNat ``Nat.mul Nat.mul
+  natPow : env.ReflectsNatNatNat ``Nat.pow Nat.pow
+  natGcd : env.ReflectsNatNatNat ``Nat.gcd Nat.gcd
+  natMod : env.ReflectsNatNatNat ``Nat.mod Nat.mod
+  natDiv : env.ReflectsNatNatNat ``Nat.div Nat.div
+  natBEq : env.ReflectsNatNatBool ``Nat.beq Nat.beq
+  natBLE : env.ReflectsNatNatBool ``Nat.ble Nat.ble
+  natLAnd : env.ReflectsNatNatNat ``Nat.land Nat.land
+  natLOr : env.ReflectsNatNatNat ``Nat.lor Nat.lor
+  natXor : env.ReflectsNatNatNat ``Nat.xor Nat.xor
+  natShiftLeft : env.ReflectsNatNatNat ``Nat.shiftLeft Nat.shiftLeft
+  natShiftRight : env.ReflectsNatNatNat ``Nat.shiftRight Nat.shiftRight
+  charOfNat : env.constants ``Char.ofNat = some ci →
+    ci = { uvars := 0, type := .forallE .nat .char }
+  stringOfList : env.constants ``String.ofList = some ci →
+    ci = { uvars := 0, type := .forallE .listChar .string } ∧
+    env.HasType 0 [] .listCharNil .listChar ∧
+    env.HasType 0 [] .listCharCons (.forallE .char <| .forallE .listChar .listChar)
+
+/-- A well-formed Boolean literal can only occur when the corresponding
+Boolean declaration is present. -/
+theorem VExpr.WF.boolLit_has_type (wf : env.Ordered)
+    (henv : env.HasPrimitives) (hΓ : OnCtx Γ (env.IsType U))
+    (H : VExpr.WF env U Γ (.boolLit b)) : env.contains ``Bool := by
+  suffices env.HasType U Γ (.boolLit b) .bool by
+    have ⟨_, H⟩ := this.isType wf hΓ
+    have ⟨_, H, _⟩ := VEnv.HasType.const_inv wf hΓ H
+    exact ⟨_, H⟩
+  cases b with
+    have ⟨_, h1, h2, h3⟩ :=
+      let ⟨_, H⟩ := H
+      VEnv.HasType.const_inv wf hΓ H
+  | false => cases henv.boolFalse h1; exact .const h1 h2 h3
+  | true => cases henv.boolTrue h1; exact .const h1 h2 h3
+
+/-- The primitive constants whose Theory reflections are tracked by
+`VEnv.HasPrimitives`. `Nat.pred` and `Nat.bitwise` are kernel primitive names
+too, but they have no dedicated fields in that contract. -/
+def VEnv.reflectedPrimitiveNames : List Name := [
+  ``Bool, ``Bool.false, ``Bool.true,
+  ``Nat, ``Nat.zero, ``Nat.succ,
+  ``Nat.add, ``Nat.sub, ``Nat.mul, ``Nat.pow,
+  ``Nat.gcd, ``Nat.mod, ``Nat.div, ``Nat.beq, ``Nat.ble,
+  ``Nat.land, ``Nat.lor, ``Nat.xor,
+  ``Nat.shiftLeft, ``Nat.shiftRight,
+  ``Char.ofNat, ``String.ofList]
+
+/-- An environment containing none of the hard-coded reflected primitive
+names satisfies the primitive-reflection contract vacuously. -/
+theorem VEnv.HasPrimitives.of_avoids
+    {env : VEnv}
+    (h : ∀ n ∈ VEnv.reflectedPrimitiveNames, env.constants n = none) :
+    env.HasPrimitives := by
+  have noContains (n) (hn : n ∈ VEnv.reflectedPrimitiveNames) :
+      ¬env.contains n := by
+    rintro ⟨ci, hci⟩
+    rw [h n hn] at hci
+    contradiction
+  have noLookup (n) (hn : n ∈ VEnv.reflectedPrimitiveNames)
+      {ci} (hci : env.constants n = some ci) : False := by
+    rw [h n hn] at hci
+    contradiction
+  exact {
+    bool := fun hc =>
+      (noContains ``Bool (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    boolFalse := fun hci =>
+      (noLookup ``Bool.false
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim
+    boolTrue := fun hci =>
+      (noLookup ``Bool.true
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim
+    nat := fun hc =>
+      (noContains ``Nat (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natZero := fun hci =>
+      (noLookup ``Nat.zero
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim
+    natSucc := fun hci =>
+      (noLookup ``Nat.succ
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim
+    natAdd := fun hc =>
+      (noContains ``Nat.add
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natSub := fun hc =>
+      (noContains ``Nat.sub
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natMul := fun hc =>
+      (noContains ``Nat.mul
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natPow := fun hc =>
+      (noContains ``Nat.pow
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natGcd := fun hc =>
+      (noContains ``Nat.gcd
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natMod := fun hc =>
+      (noContains ``Nat.mod
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natDiv := fun hc =>
+      (noContains ``Nat.div
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natBEq := fun hc =>
+      (noContains ``Nat.beq
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natBLE := fun hc =>
+      (noContains ``Nat.ble
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natLAnd := fun hc =>
+      (noContains ``Nat.land
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natLOr := fun hc =>
+      (noContains ``Nat.lor
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natXor := fun hc =>
+      (noContains ``Nat.xor
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natShiftLeft := fun hc =>
+      (noContains ``Nat.shiftLeft
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    natShiftRight := fun hc =>
+      (noContains ``Nat.shiftRight
+        (by simp [VEnv.reflectedPrimitiveNames]) hc).elim
+    charOfNat := fun hci =>
+      (noLookup ``Char.ofNat
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim
+    stringOfList := fun hci =>
+      (noLookup ``String.ofList
+        (by simp [VEnv.reflectedPrimitiveNames]) hci).elim }
+
+/-- A fresh Theory constant leaves every other lookup unchanged. -/
+theorem VEnv.addConst_other
+    {env env' : VEnv} {name other : Name} {ci : VConstant}
+    (hadd : env.addConst name ci = some env')
+    (hne : name ≠ other) :
+    env'.constants other = env.constants other := by
+  unfold VEnv.addConst at hadd
+  split at hadd <;> cases hadd
+  simp [hne]
+
+/-- Inserting a non-reflected constant preserves the primitive-reflection
+contract. -/
+theorem VEnv.HasPrimitives.addConst
+    {env env' : VEnv} {name : Name} {ci : VConstant}
+    (H : env.HasPrimitives)
+    (hname : name ∉ VEnv.reflectedPrimitiveNames)
+    (hadd : env.addConst name ci = some env') :
+    env'.HasPrimitives := by
+  have lookup (other : Name) (hother : other ∈ VEnv.reflectedPrimitiveNames) :
+      env'.constants other = env.constants other :=
+    VEnv.addConst_other hadd (by
+      intro equality
+      apply hname
+      simpa only [equality] using hother)
+  have oldContains (other : Name)
+      (hother : other ∈ VEnv.reflectedPrimitiveNames) :
+      env'.contains other → env.contains other := by
+    rintro ⟨value, hvalue⟩
+    exact ⟨value, by simpa only [lookup other hother] using hvalue⟩
+  have newContains (other : Name) :
+      env.contains other → env'.contains other := by
+    rintro ⟨value, hvalue⟩
+    exact ⟨value, (VEnv.addConst_le hadd).constants hvalue⟩
+  have hle := VEnv.addConst_le hadd
+  exact {
+    bool := fun h => by
+      obtain ⟨hfalse, htrue⟩ := H.bool (oldContains ``Bool
+        (by simp [VEnv.reflectedPrimitiveNames]) h)
+      exact ⟨newContains _ hfalse, newContains _ htrue⟩
+    boolFalse := fun h => H.boolFalse (by
+      simpa only [lookup ``Bool.false
+        (by simp [VEnv.reflectedPrimitiveNames])] using h)
+    boolTrue := fun h => H.boolTrue (by
+      simpa only [lookup ``Bool.true
+        (by simp [VEnv.reflectedPrimitiveNames])] using h)
+    nat := fun h => by
+      obtain ⟨hzero, hsucc⟩ := H.nat (oldContains ``Nat
+        (by simp [VEnv.reflectedPrimitiveNames]) h)
+      exact ⟨newContains _ hzero, newContains _ hsucc⟩
+    natZero := fun h => H.natZero (by
+      simpa only [lookup ``Nat.zero
+        (by simp [VEnv.reflectedPrimitiveNames])] using h)
+    natSucc := fun h => H.natSucc (by
+      simpa only [lookup ``Nat.succ
+        (by simp [VEnv.reflectedPrimitiveNames])] using h)
+    natAdd := fun h a b =>
+      (H.natAdd (oldContains ``Nat.add
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natSub := fun h a b =>
+      (H.natSub (oldContains ``Nat.sub
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natMul := fun h a b =>
+      (H.natMul (oldContains ``Nat.mul
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natPow := fun h a b =>
+      (H.natPow (oldContains ``Nat.pow
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natGcd := fun h a b =>
+      (H.natGcd (oldContains ``Nat.gcd
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natMod := fun h a b =>
+      (H.natMod (oldContains ``Nat.mod
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natDiv := fun h a b =>
+      (H.natDiv (oldContains ``Nat.div
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natBEq := fun h a b =>
+      (H.natBEq (oldContains ``Nat.beq
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natBLE := fun h a b =>
+      (H.natBLE (oldContains ``Nat.ble
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natLAnd := fun h a b =>
+      (H.natLAnd (oldContains ``Nat.land
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natLOr := fun h a b =>
+      (H.natLOr (oldContains ``Nat.lor
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natXor := fun h a b =>
+      (H.natXor (oldContains ``Nat.xor
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natShiftLeft := fun h a b =>
+      (H.natShiftLeft (oldContains ``Nat.shiftLeft
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    natShiftRight := fun h a b =>
+      (H.natShiftRight (oldContains ``Nat.shiftRight
+        (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle
+    charOfNat := fun h => H.charOfNat (by
+      simpa only [lookup ``Char.ofNat
+        (by simp [VEnv.reflectedPrimitiveNames])] using h)
+    stringOfList := fun h => by
+      obtain ⟨hconstant, hnil, hcons⟩ := H.stringOfList (by
+        simpa only [lookup ``String.ofList
+          (by simp [VEnv.reflectedPrimitiveNames])] using h)
+      exact ⟨hconstant, hnil.mono hle, hcons.mono hle⟩ }
+
+variable! {env env' : VEnv} (henv : env ≤ env') in
+theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLits l
+  | .natVal _, ⟨_, H⟩ => ⟨_, henv.constants H⟩
+  | .strVal _, ⟨⟨_, H1⟩, ⟨_, H2⟩⟩ =>
+    ⟨⟨_, henv.constants H1⟩, ⟨_, henv.constants H2⟩⟩
+
+namespace VEnv.PreludeReady
+
+theorem boolFalse_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Bool.false = some { uvars := 0, type := VExpr.bool } := by
+  simpa [LiteralPrelude.boolFalse] using H.boolFalse
+
+theorem boolTrue_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Bool.true = some { uvars := 0, type := VExpr.bool } := by
+  simpa [LiteralPrelude.boolTrue] using H.boolTrue
+
+theorem natZero_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Nat.zero = some { uvars := 0, type := VExpr.nat } := by
+  simpa [LiteralPrelude.natZero] using H.natZero
+
+theorem natSucc_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Nat.succ =
+      some { uvars := 0, type := VExpr.forallE .nat .nat } := by
+  simpa [LiteralPrelude.natSucc] using H.natSucc
+
+theorem char_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Char =
+      some { uvars := 0, type := VExpr.sort (.succ .zero) } := by
+  simpa [LiteralPrelude.char] using H.char
+
+theorem charOfNat_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``Char.ofNat =
+      some { uvars := 0, type := VExpr.forallE .nat .char } := by
+  simpa [LiteralPrelude.charOfNat] using H.charOfNat
+
+theorem stringOfList_lookup {env : VEnv} (H : env.PreludeReady) :
+    env.constants ``String.ofList =
+      some { uvars := 0, type := VExpr.forallE .listChar .string } := by
+  simpa [LiteralPrelude.stringOfList] using H.stringOfList
+
+theorem boolLit_hasType {env : VEnv} (H : env.PreludeReady) (b : Bool) :
+    env.HasType U Γ (.boolLit b) .bool := by
+  cases b
+  · exact .const H.boolFalse_lookup nofun rfl
+  · exact .const H.boolTrue_lookup nofun rfl
+
+theorem natLit_hasType {env : VEnv} (H : env.PreludeReady) (n : Nat) :
+    env.HasType U Γ (.natLit n) .nat := by
+  induction n with
+  | zero => exact .const H.natZero_lookup nofun rfl
+  | succ n ih =>
+    simpa [VExpr.natLit, VExpr.natSucc, VExpr.nat, VExpr.instL, VExpr.inst] using
+      VEnv.HasType.app
+        (VEnv.HasType.const (ls := []) H.natSucc_lookup (by simp) rfl) ih
+
+theorem charOfNat_hasType {env : VEnv} (H : env.PreludeReady) :
+    env.HasType U Γ .charOfNat (.forallE .nat .char) :=
+  .const H.charOfNat_lookup nofun rfl
+
+theorem listCharNil_hasType {env : VEnv} (H : env.PreludeReady) :
+    env.HasType U Γ .listCharNil .listChar := by
+  have hnil : env.constants ``List.nil = some {
+      uvars := 1
+      type := VExpr.forallE (.sort (.succ (.param 0)))
+        (.app (.const ``List [.param 0]) (.bvar 0)) } := by
+    simpa [LiteralPrelude.listNil] using H.listNil
+  exact .app (.const hnil (by simp [VLevel.WF]) rfl)
+    (.const H.char_lookup nofun rfl)
+
+theorem listCharCons_hasType {env : VEnv} (H : env.PreludeReady) :
+    env.HasType U Γ .listCharCons
+      (.forallE .char <| .forallE .listChar .listChar) := by
+  have hcons : env.constants ``List.cons = some {
+      uvars := 1
+      type := VExpr.forallE (.sort (.succ (.param 0))) <|
+        .forallE (.bvar 0) <|
+          .forallE (.app (.const ``List [.param 0]) (.bvar 1))
+            (.app (.const ``List [.param 0]) (.bvar 2)) } := by
+    simpa [LiteralPrelude.listCons] using H.listCons
+  exact .app (.const hcons (by simp [VLevel.WF]) rfl)
+    (.const H.char_lookup nofun rfl)
+
+theorem listCharLit_hasType {env : VEnv} (H : env.PreludeReady)
+    (cs : List Char) : env.HasType U Γ (.listCharLit cs) .listChar := by
+  induction cs with
+  | nil => exact H.listCharNil_hasType
+  | cons c cs ih =>
+    exact (H.listCharCons_hasType.app
+      (H.charOfNat_hasType.app (H.natLit_hasType c.toNat))).app ih
+
+theorem trLiteral_hasType {env : VEnv} (H : env.PreludeReady) (l : Literal) :
+    env.HasType U Γ (.trLiteral l) (.literalType l) := by
+  cases l with
+  | natVal n => simpa [VExpr.trLiteral, VExpr.literalType] using H.natLit_hasType n
+  | strVal s =>
+    simpa [VExpr.trLiteral, VExpr.literalType, VExpr.stringOfList, VExpr.string,
+      VExpr.instL, VExpr.inst] using
+      VEnv.HasType.app
+        (VEnv.HasType.const (ls := []) H.stringOfList_lookup (by simp) rfl)
+        (H.listCharLit_hasType s.toList)
+
+/-- Exact readiness, not name occurrence alone, makes a direct literal
+encoding well-formed.  Pattern matching the containment witness ensures the
+literal-facing premise is checked against the exact ready lookup. -/
+theorem trLiteral_wf {env : VEnv} (H : env.PreludeReady) (l : Literal)
+    (hcontains : env.ContainsLits l) :
+    VExpr.WF env U [] (.trLiteral l) := by
+  cases l with
+  | natVal n =>
+    obtain ⟨ci, hci⟩ := hcontains
+    have : ci = LiteralPrelude.natType.toVConstant := by
+      exact (Option.some.inj (H.nat.symm.trans hci)).symm
+    subst ci
+    exact ⟨_, H.trLiteral_hasType (.natVal n)⟩
+  | strVal s =>
+    obtain ⟨⟨charOfNat, hcharOfNat⟩, ⟨stringOfList, hstringOfList⟩⟩ := hcontains
+    have : charOfNat = LiteralPrelude.charOfNat := by
+      exact (Option.some.inj (H.charOfNat.symm.trans hcharOfNat)).symm
+    subst charOfNat
+    have : stringOfList = LiteralPrelude.stringOfList := by
+      exact (Option.some.inj (H.stringOfList.symm.trans hstringOfList)).symm
+    subst stringOfList
+    exact ⟨_, H.trLiteral_hasType (.strVal s)⟩
+
+end VEnv.PreludeReady
+
+@[simp] theorem VExpr.instL_boolFalse : VExpr.boolFalse.instL ls = VExpr.boolFalse := by
+  simp [boolFalse, instL]
+
+@[simp] theorem VExpr.instL_boolTrue : VExpr.boolTrue.instL ls = VExpr.boolTrue := by
+  simp [boolTrue, instL]
+
+@[simp] theorem VExpr.instL_boolLit : (VExpr.boolLit b).instL ls = VExpr.boolLit b := by
+  cases b <;> simp [boolLit]
+
+@[simp] theorem VExpr.liftN_boolLit : (VExpr.boolLit b).liftN n k = VExpr.boolLit b := by
+  cases b <;> rfl
+
+@[simp] theorem VExpr.lift'_boolLit : (VExpr.boolLit b).lift' ρ = VExpr.boolLit b := by
+  cases b <;> rfl
+
+@[simp] theorem VExpr.inst_boolLit : (VExpr.boolLit b).inst e k = VExpr.boolLit b := by
+  cases b <;> rfl
+
+@[simp] theorem VExpr.instL_natZero : VExpr.natZero.instL ls = .natZero := by
+  simp [natZero, instL]
+
+@[simp] theorem VExpr.instL_natSucc : VExpr.natSucc.instL ls = .natSucc := by
+  simp [natSucc, instL]
+
+@[simp] theorem VExpr.instL_natLit : (VExpr.natLit n).instL ls = VExpr.natLit n := by
+  induction n <;> simp [*, natLit, instL]
+
+@[simp] theorem VExpr.liftN_natLit : (VExpr.natLit a).liftN n k = VExpr.natLit a := by
+  induction a <;> simp [natLit, natZero, natSucc, VExpr.liftN, *]
+
+@[simp] theorem VExpr.lift'_natLit : (VExpr.natLit a).lift' ρ = VExpr.natLit a := by
+  induction a <;> simp [natLit, natZero, natSucc, VExpr.lift', *]
+
+@[simp] theorem VExpr.inst_natLit : (VExpr.natLit a).inst e k = VExpr.natLit a := by
+  induction a <;> simp [natLit, natZero, natSucc, VExpr.inst, *]
+
+@[simp] theorem VExpr.liftN_listCharLit :
+    (VExpr.listCharLit cs).liftN n k = VExpr.listCharLit cs := by
+  induction cs <;>
+    simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.liftN, *]
+
+@[simp] theorem VExpr.lift'_listCharLit :
+    (VExpr.listCharLit cs).lift' ρ = VExpr.listCharLit cs := by
+  induction cs <;>
+    simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.lift', *]
+
+@[simp] theorem VExpr.inst_listCharLit :
+    (VExpr.listCharLit cs).inst e k = VExpr.listCharLit cs := by
+  induction cs <;>
+    simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.inst, *]
+
+@[simp] theorem VExpr.instL_listCharLit :
+    (VExpr.listCharLit cs).instL ls = VExpr.listCharLit cs := by
+  induction cs <;>
+    simp [listCharLit, listCharNil, listCharCons, char, charOfNat,
+      VExpr.instL, VLevel.inst, *]
+
+@[simp] theorem VExpr.liftN_trLiteral :
+    (VExpr.trLiteral l).liftN n k = VExpr.trLiteral l := by
+  cases l <;> simp [trLiteral, stringOfList, VExpr.liftN]
+
+@[simp] theorem VExpr.lift'_trLiteral :
+    (VExpr.trLiteral l).lift' ρ = VExpr.trLiteral l := by
+  cases l <;> simp [trLiteral, stringOfList, VExpr.lift']
+
+@[simp] theorem VExpr.inst_trLiteral :
+    (VExpr.trLiteral l).inst e k = VExpr.trLiteral l := by
+  cases l <;> simp [trLiteral, stringOfList, VExpr.inst]
+
+@[simp] theorem VExpr.instL_trLiteral :
+    (VExpr.trLiteral l).instL ls = VExpr.trLiteral l := by
+  cases l <;> simp [trLiteral, stringOfList, VExpr.instL]
+
+theorem VEnv.HasPrimitives.nat_of_charOfNat (wf : Ordered env)
+    (henv : env.HasPrimitives) (H : env.contains ``Char.ofNat) : env.contains ``Nat := by
+  let ⟨_, H⟩ := H
+  have ⟨_, H⟩ := wf.constWF (henv.charOfNat H ▸ H)
+  let ⟨⟨_, H⟩, _⟩ := H.forallE_inv wf
+  let ⟨_, H, _⟩ := H.const_inv (Γ := []) wf (by trivial)
+  exact ⟨_, H⟩
+
+/--
+info: 'Lean4Lean.VEnv.PreludeReady.mono' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.PreludeReady.mono
+
+/--
+info: 'Lean4Lean.VEnv.PreludeReady.addConst' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.PreludeReady.addConst
+
+/--
+info: 'Lean4Lean.VEnv.PreludeReady.addDefEq' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.PreludeReady.addDefEq
+
+/--
+info: 'Lean4Lean.VEnv.PreludeReady.trLiteral_wf' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VEnv.PreludeReady.trLiteral_wf
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/LocalContext.lean b/Lean4Lean/Theory/LocalContext.lean
new file mode 100644
index 00000000..a196f315
--- /dev/null
+++ b/Lean4Lean/Theory/LocalContext.lean
@@ -0,0 +1,149 @@
+import Lean4Lean.Theory.Typing.UniqueTyping
+
+/-! # Theory local declarations
+
+The implementation-independent core of a local context.  `VLocalDecl` only
+mentions Theory expressions; the `Lean.FVarId` bookkeeping used by the
+verified Lean-expression translator remains in `Lean4Lean.Verify.VLCtx`.
+-/
+
+namespace Lean4Lean
+open VEnv
+
+inductive VLocalDecl where
+  | vlam (type : VExpr)
+  | vlet (type value : VExpr)
+
+def VLocalDecl.depth : VLocalDecl → Nat
+  | .vlam .. => 1
+  | .vlet .. => 0
+
+def VLocalDecl.value : VLocalDecl → VExpr
+  | .vlam .. => .bvar 0
+  | .vlet _ e => e
+
+def VLocalDecl.type' : VLocalDecl → VExpr
+  | .vlam A
+  | .vlet A _ => A
+
+def VLocalDecl.type : VLocalDecl → VExpr
+  | .vlam A => A.lift
+  | .vlet A _ => A
+
+def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl
+  | .vlam A, n => .vlam (A.lift' n)
+  | .vlet A e, n => .vlet (A.lift' n) (e.lift' n)
+
+def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl
+  | .vlam A, n, k => .vlam (A.liftN n k)
+  | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k)
+
+def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl
+  | .vlam A, e₀, k => .vlam (A.inst e₀ k)
+  | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k)
+
+def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl
+  | .vlam A, ls => .vlam (A.instL ls)
+  | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls)
+
+def VLocalDecl.WF (env : VEnv) (U : Nat) (Γ : List VExpr) : VLocalDecl → Prop
+  | .vlam type => env.IsType U Γ type
+  | .vlet type value => env.HasType U Γ value type
+
+def VLocalDecl.ClosedN : VLocalDecl → (k : Nat := 0) → Prop
+  | .vlam A, k => A.ClosedN k
+  | .vlet A e, k => A.ClosedN k ∧ e.ClosedN k
+
+variable! (env : VEnv) (U : Nat) (Γ : List VExpr) in
+inductive VLocalDecl.IsDefEq : VLocalDecl → VLocalDecl → Prop
+  | vlam : env.IsDefEq U Γ type₁ type₂ (.sort u) →
+      VLocalDecl.IsDefEq (.vlam type₁) (.vlam type₂)
+  | vlet :
+    env.IsDefEq U Γ value₁ value₂ type₁ → env.IsDefEq U Γ type₁ type₂ (.sort u) →
+    VLocalDecl.IsDefEq (.vlet type₁ value₁) (.vlet type₂ value₂)
+
+theorem VLocalDecl.lift'_consN_skipN {d : VLocalDecl} :
+    d.lift' (.consN (.skipN .refl n) k) = d.liftN n k := by
+  cases d <;> simp [VLocalDecl.lift', VLocalDecl.liftN, VExpr.lift'_consN_skipN]
+
+nonrec theorem VLocalDecl.WF.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') :
+    ∀ {d}, WF env U Γ d → WF env U Γ' (d.liftN n k)
+  | .vlam _, H | .vlet .., H => H.weakN henv W
+
+nonrec theorem VLocalDecl.WF.instN (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (h₀ : env.HasType U Γ₀ e₀ A₀) : ∀ {d}, WF env U Γ₁ d → WF env U Γ (d.inst e₀ k)
+  | .vlam _, H | .vlet .., H => H.instN henv W h₀
+
+nonrec theorem VLocalDecl.WF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') :
+    ∀ {d}, WF env ls.length Γ d → WF env U' (Γ.map (·.instL ls)) (d.instL ls)
+  | .vlam _, H | .vlet .., H => H.instL hls
+
+@[simp] theorem VLocalDecl.lift'_depth {d : VLocalDecl} : (d.lift' n).depth = d.depth := by
+  cases d <;> rfl
+
+theorem VLocalDecl.lift'_comp {d : VLocalDecl} :
+    d.lift' (.comp l₁ l₂) = (d.lift' l₁).lift' l₂ := by
+  cases d <;> simp [VLocalDecl.lift', VExpr.lift'_comp]
+
+variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U))
+    (W : Ctx.Lift' n Γ Γ') in
+theorem VLocalDecl.weak'_iff :
+    VLocalDecl.WF env U Γ' (d.lift' n) ↔ VLocalDecl.WF env U Γ d :=
+  match d with
+  | .vlam .. => IsType.weak'_iff henv hΓ' W
+  | .vlet .. => HasType.weak'_iff henv hΓ' W
+
+variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U))
+    (W : Ctx.LiftN n k Γ Γ') in
+theorem VLocalDecl.weakN_iff :
+    VLocalDecl.WF env U Γ' (d.liftN n k) ↔ VLocalDecl.WF env U Γ d :=
+  match d with
+  | .vlam .. => IsType.weakN_iff henv hΓ' W
+  | .vlet .. => HasType.weakN_iff henv hΓ' W
+
+variable! (henv : Ordered env) (hΓ : OnCtx Γ (IsType env U)) in
+theorem VLocalDecl.IsDefEq.refl :
+    ∀ {d}, VLocalDecl.WF env U Γ d → VLocalDecl.IsDefEq env U Γ d d
+  | .vlam _, ⟨_, h1⟩ => .vlam h1
+  | .vlet .., h1 => let ⟨_, h2⟩ := h1.isType henv hΓ; .vlet h1 h2
+
+theorem VLocalDecl.IsDefEq.wf :
+    VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.WF env U Γ d₁
+  | .vlam h3 => ⟨_, h3.hasType.1⟩
+  | .vlet h3 _ => h3.hasType.1
+
+theorem VLocalDecl.IsDefEq.mono (henv : env ≤ env') :
+    VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env' U Γ d₁ d₂
+  | .vlam h => .vlam (h.mono henv)
+  | .vlet h₁ h₂ => .vlet (h₁.mono henv) (h₂.mono henv)
+
+theorem VLocalDecl.IsDefEq.symm :
+    VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env U Γ d₂ d₁
+  | .vlam h1 => .vlam h1.symm
+  | .vlet h1 h2 => .vlet (h2.defeqDF h1.symm) h2.symm
+
+theorem VLocalDecl.IsDefEq.defeqDFC (henv : Ordered env)
+    (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) :
+    VLocalDecl.IsDefEq env U Γ₁ d₁ d₂ → VLocalDecl.IsDefEq env U Γ₂ d₁ d₂
+  | .vlam h1 => .vlam (h1.defeqDFC henv hΓ)
+  | .vlet h1 h2 => .vlet (h1.defeqDFC henv hΓ) (h2.defeqDFC henv hΓ)
+
+/--
+info: 'Lean4Lean.VLocalDecl.WF.weakN' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VLocalDecl.WF.weakN
+
+/--
+info: 'Lean4Lean.VLocalDecl.weakN_iff' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VLocalDecl.weakN_iff
+
+/--
+info: 'Lean4Lean.VLocalDecl.IsDefEq.defeqDFC' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms VLocalDecl.IsDefEq.defeqDFC
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/NestedInductive.lean b/Lean4Lean/Theory/NestedInductive.lean
new file mode 100644
index 00000000..b8d6a386
--- /dev/null
+++ b/Lean4Lean/Theory/NestedInductive.lean
@@ -0,0 +1,526 @@
+import Lean4Lean.Theory.Inductive
+
+/-!
+# Nested-inductive flattening (L4L-09B)
+
+The Theory mirror of the kernel's `ElimNestedInductive` transformation,
+following the committed L4L-09A design
+(`Lean4Lean/Verify/Environment/NestedRepresentation.lean`): the stored
+payload of a nested declaration is the source `VInductDecl`, and nested
+support flows through an additive artifact coupling
+
+1. the flattened mutual block, an ordinary `VInductDecl` handled by the
+   existing arbitrary-block analyzer, and
+2. one auxiliary specification per auxiliary family — the Theory analog of
+   the kernel's `aux2nested` map.
+
+`nestedElimination?` computes both from the source declaration plus the
+caller-supplied metadata of the previously declared inductives that are
+nested into (`NestedTargetBlock`).  Keeping the target metadata an explicit
+input keeps this analyzer environment-free, exactly like `checked?`;
+`NestedTargetBlock.WF` separately ties the supplied copy to a Theory
+environment.
+
+The transformation mirrors the kernel phase for phase:
+
+- An application `I Ds is` is a nested occurrence when `I` is a family of a
+  supplied target block, the spine covers at least `I`'s parameters, and
+  the parametric arguments `Ds` mention a family of the growing flattened
+  block.  Parametric arguments that also mention a constructor-local binder
+  reject the declaration (the kernel's "parameters cannot contain local
+  variables"), and matched occurrences are rewritten without descending
+  into the emitted replacement, exactly like `Expr.replace`.
+- One auxiliary family is created per family of `I`'s block, in `all`
+  order, with `I`'s family and constructor types level-instantiated at the
+  occurrence's levels and parameter-instantiated at `Ds`; auxiliary
+  constructor bodies are queued and flattened by the same loop until the
+  block is stable.
+- Auxiliary names are canonical: `(`_nested` ++ familyName).appendIndexAfter i`
+  with a global counter, matching the kernel's choice whenever the ambient
+  environment contains no colliding `_nested.*` constant.  The L4L-09A
+  collision probe shows the choice is erased from all final artifacts, and
+  in-block collisions are rejected downstream by `blockNamesOK` exactly
+  where the kernel's `checkName` rejects its own collisions.
+
+Acceptance (`nestedStage3`) is flattening success plus generation
+readiness of the flattened block through the unchanged L4L-08 machinery.
+No generated recursor, rule, or environment replay is claimed at this
+checkpoint; the restoration substitution over generation artifacts is
+L4L-09C's obligation.
+-/
+
+namespace Lean4Lean
+
+deriving instance DecidableEq for VConstant
+deriving instance DecidableEq for VDefEq
+deriving instance DecidableEq for VConstVal
+deriving instance DecidableEq for VInductiveType
+deriving instance DecidableEq for VInductDecl
+
+/-- Does `e` mention, through a loose bvar, one of the `k` binders directly
+below its root?  `d` counts binders passed inside `e` itself. -/
+def VExpr.hasLooseBelow (k : Nat) : VExpr → (d : Nat := 0) → Bool
+  | .bvar i, d => d ≤ i && i - d < k
+  | .sort _, _ | .const .., _ => false
+  | .app e1 e2, d => e1.hasLooseBelow k d || e2.hasLooseBelow k d
+  | .lam e1 e2, d | .forallE e1 e2, d =>
+      e1.hasLooseBelow k d || e2.hasLooseBelow k (d+1)
+
+/-- Lower every loose bvar of `e` by `n`.  Total; meaningful only when no
+loose bvar lies below `n`, which callers establish with `hasLooseBelow`. -/
+def VExpr.lowerN (n : Nat) : VExpr → (d : Nat := 0) → VExpr
+  | .bvar i, d => if i < d then .bvar i else .bvar (i - n)
+  | .sort l, _ => .sort l
+  | .const c ls, _ => .const c ls
+  | .app e1 e2, d => .app (e1.lowerN n d) (e2.lowerN n d)
+  | .lam e1 e2, d => .lam (e1.lowerN n d) (e2.lowerN n (d+1))
+  | .forallE e1 e2, d => .forallE (e1.lowerN n d) (e2.lowerN n (d+1))
+
+namespace VInductDecl
+
+/-- Simultaneous outermost-first parameter substitution: the first list
+element replaces the outermost of the `args.length` innermost loose bvars.
+The same shape as `instantiateRev` on the implementation side. -/
+def instRevParams : VExpr → List VExpr → VExpr
+  | C, [] => C
+  | C, e :: es => instRevParams (C.inst e es.length) es
+
+/-- Substitute the leading `np`-binder telescope of `ty` simultaneously at
+`args` (outermost parameter first), mirroring the kernel's
+`instantiateForallParams`.  Fails when `ty` exposes fewer than `np`
+binders. -/
+def instTelescope (np : Nat) (ty : VExpr) (args : List VExpr) :
+    Option VExpr := do
+  guard (args.length == np)
+  guard ((VExpr.telN np ty).length == np)
+  return instRevParams (VExpr.dropN np ty) args
+
+/-- One previously declared mutual block that nested occurrences may point
+into.  `families` is the complete block in `all` order, in that block's own
+universe parameters; a copy is supplied so the analyzer stays
+environment-free, and `NestedTargetBlock.WF` ties the copy to an
+environment. -/
+structure NestedTargetBlock where
+  nparams : Nat
+  families : List VInductiveType
+
+/-- The supplied target copy agrees with the environment's stored
+constants. -/
+structure NestedTargetBlock.WF (env : VEnv) (block : NestedTargetBlock) :
+    Prop where
+  families : ∀ f ∈ block.families,
+    env.constants f.name = some f.toVConstVal.toVConstant
+  ctors : ∀ f ∈ block.families, ∀ c ∈ f.ctors,
+    env.constants c.name = some c.toVConstant
+
+def NestedTargetsWF (env : VEnv) (targets : List NestedTargetBlock) : Prop :=
+  ∀ t ∈ targets, t.WF env
+
+/-- One auxiliary family created by nested elimination: the Theory analog
+of one `aux2nested` binding.  `values` are the parametric arguments `Ds`,
+open over the block parameters (innermost bvar = last parameter), in
+declaration level-world. -/
+structure NestedAuxSpec where
+  aux : Name
+  target : Name
+  levels : List VLevel
+  values : List VExpr
+  deriving DecidableEq
+
+/-- The nested occurrence this auxiliary family abbreviates: `I Ds`. -/
+def NestedAuxSpec.value (spec : NestedAuxSpec) : VExpr :=
+  (VExpr.const spec.target spec.levels).appN spec.values
+
+/-- The flattening result: the flattened mutual block plus one auxiliary
+specification per auxiliary family, in flattened family order.  When the
+source contains no nested occurrence, `flat` is the source itself and
+`specs` is empty. -/
+structure NestedElimination (source : VInductDecl) where
+  flat : VInductDecl
+  specs : List NestedAuxSpec
+
+namespace ElimNested
+
+/-- Growing flattening state.  `types` extends the source families with the
+auxiliary families; `specs` aligns with `types.drop ntypes`. -/
+structure State where
+  types : Array VInductiveType
+  specs : Array NestedAuxSpec
+  nextIdx : Nat := 1
+
+variable (targets : List NestedTargetBlock) (uvars np : Nat)
+
+/-- The target block owning family `c`, ignoring names that are currently
+part of the flattened block itself (the kernel only recognizes previously
+*declared* inductives). -/
+def findTarget? (st : State) (c : Name) : Option NestedTargetBlock :=
+  if st.types.any (·.name == c) then none
+  else targets.find? fun t => t.families.any (·.name == c)
+
+/-- Register the auxiliary families for one first-seen nested occurrence
+`I Ds` and return the auxiliary family name standing for `I` itself.
+`doms` is the discovering constructor's parameter telescope, and `values`
+are the parametric arguments in parameter-world. -/
+def registerAux (st : State) (block : NestedTargetBlock) (I : Name)
+    (ls : List VLevel) (doms values : List VExpr) :
+    Option (Name × State) := do
+  let mut st := st
+  let mut result := none
+  for J in block.families do
+    if J.uvars != ls.length then failure
+    let auxName := (`_nested ++ J.name).appendIndexAfter st.nextIdx
+    let auxType ← instTelescope block.nparams (J.type.instL ls) values
+    let mut auxCtors : List VConstVal := []
+    for c in J.ctors do
+      let ctype ← instTelescope block.nparams (c.type.instL ls) values
+      auxCtors := auxCtors ++
+        [⟨⟨uvars, VExpr.forallN doms ctype⟩, c.name.replacePrefix J.name auxName⟩]
+    let auxFamily : VInductiveType :=
+      { name := auxName, uvars, type := VExpr.forallN doms auxType
+        ctors := auxCtors }
+    st :=
+      { types := st.types.push auxFamily
+        specs := st.specs.push ⟨auxName, J.name, ls, values⟩
+        nextIdx := st.nextIdx + 1 }
+    if J.name == I then result := some auxName
+  match result with
+  | some auxName => return (auxName, st)
+  | none => none
+
+/-- Rewrite one constructor-body subterm at binder depth `k`, mirroring
+`replaceAllNested`: matched occurrences are replaced without descending
+into the replacement; unmatched nodes recurse into their children. -/
+def replace (doms : List VExpr) :
+    VExpr → (k : Nat) → State → Option (VExpr × State)
+  | e@(.app f a), k, st => do
+      match rewrite? e k st with
+      | some result => result
+      | none =>
+          let (f', st) ← replace doms f k st
+          let (a', st) ← replace doms a k st
+          return (.app f' a', st)
+  | e@(.const ..), k, st => (rewrite? e k st).getD (some (e, st))
+  | .lam ty body, k, st => do
+      let (ty', st) ← replace doms ty k st
+      let (body', st) ← replace doms body (k+1) st
+      return (.lam ty' body', st)
+  | .forallE ty body, k, st => do
+      let (ty', st) ← replace doms ty k st
+      let (body', st) ← replace doms body (k+1) st
+      return (.forallE ty' body', st)
+  | e, _, st => some (e, st)
+  where
+  /-- `some (some ..)` rewrites the node, `some none` is a hard rejection,
+  `none` leaves the node to the structural recursion. -/
+  rewrite? (e : VExpr) (k : Nat) (st : State) :
+      Option (Option (VExpr × State)) := do
+    let .const c ls := VExpr.appHead e | none
+    let args := e.appArgs []
+    let block ← findTarget? targets st c
+    guard (block.nparams ≤ args.length)
+    guard (0 < block.nparams)
+    let ds := args.take block.nparams
+    let names := st.types.toList.map (·.name)
+    guard (ds.any (·.hasAnyConst names))
+    -- the kernel's "nested inductive datatypes parameters cannot contain
+    -- local variables" rejection
+    if ds.any (·.hasLooseBelow k) then return none
+    let values := ds.map (·.lowerN k)
+    let key := (VExpr.const c ls).appN values
+    let rest := args.drop block.nparams
+    let recover (auxName : Name) (st : State) : VExpr × State :=
+      ((VExpr.const auxName (VLevel.params uvars)).appN
+        (VExpr.bvarRevRange k np ++ rest), st)
+    match st.specs.find? (·.value == key) with
+    | some spec => return some (recover spec.aux st)
+    | none =>
+        match registerAux uvars st block c ls doms values with
+        | some (auxName, st) => return some (recover auxName st)
+        | none => return none
+
+/-- Flatten every constructor of every block family, including the queued
+auxiliary families, until the block is stable.  `fuel` mirrors the
+kernel's `inductiveFuel` bound on the same loop. -/
+def run (fuel : Nat) (i : Nat) (st : State) : Option State :=
+  match fuel with
+  | 0 => none
+  | fuel+1 =>
+    if h : i < st.types.size then
+      let ty := st.types[i]
+      let step := ty.ctors.foldlM (init := ([], st)) fun (acc, st) c => do
+        let doms := VExpr.telN np c.type
+        guard (doms.length == np)
+        let (body, st) ← replace targets uvars np doms (VExpr.dropN np c.type) 0 st
+        return (acc ++ [{ c with type := VExpr.forallN doms body }], st)
+      match step with
+      | some (ctors, st) =>
+          run fuel (i+1) { st with types := st.types.set! i { ty with ctors } }
+      | none => none
+    else some st
+
+end ElimNested
+
+/-- Flatten one source declaration against the supplied target blocks.
+Returns the flattened block plus the auxiliary specifications; the
+identity result (`flat = source`, no specs) is returned when nothing is
+nested. -/
+def nestedElimination? (targets : List NestedTargetBlock)
+    (source : VInductDecl) (fuel : Nat := 1000) :
+    Option (NestedElimination source) := do
+  let st ← ElimNested.run targets source.uvars source.nparams fuel 0
+    { types := source.types.toArray, specs := #[] }
+  return { flat := { source with types := st.types.toList }
+           specs := st.specs.toList }
+
+/-- The number of auxiliary families, matching the stored
+`InductiveVal.numNested` of an accepted nested declaration. -/
+def NestedElimination.numNested {source : VInductDecl}
+    (elim : NestedElimination source) : Nat :=
+  elim.specs.length
+
+/-- A flattened declaration accepted by the unchanged arbitrary-block
+machinery: the complete L4L-09B validation gate.  Positivity, name, level,
+anatomy, and generation-shape checking of the flattened block reuse the
+L4L-08 analyzers verbatim. -/
+structure NestedBlockChecked (source : VInductDecl) where
+  elim : NestedElimination source
+  generation : BlockGenerationChecked elim.flat
+
+def nestedBlockChecked? (targets : List NestedTargetBlock)
+    (source : VInductDecl) (fuel : Nat := 1000) :
+    Option (NestedBlockChecked source) := do
+  let elim ← nestedElimination? targets source fuel
+  let generation ← elim.flat.identityBlockGeneration?
+  return ⟨elim, generation⟩
+
+/-- Structural acceptance for a nested declaration. -/
+def nestedStage3 (targets : List NestedTargetBlock)
+    (source : VInductDecl) (fuel : Nat := 1000) : Bool :=
+  (nestedBlockChecked? targets source fuel).isSome
+
+/-! ## Restoration (L4L-09C)
+
+The restoration substitution σ maps the flattened block's generation
+artifacts back to the stored metadata surface: auxiliary family constants
+become their nested values, auxiliary constructor constants become the
+target block's constructors applied to the instantiated value's own
+arguments, and auxiliary recursor constants are renamed onto the main
+family's `appendIndexAfter` inventory.  On an application spine headed by
+an auxiliary family or constructor, the first `nparams` spine arguments
+are consumed by the value instantiation, mirroring
+`ElimNestedInductive.Result.restoreNested`; generated artifacts always
+apply auxiliary constants to at least the block parameters (the kernel
+asserts exactly this), so the identity fallback on an under-applied
+auxiliary head is unreachable from real artifacts and merely keeps σ
+total. -/
+
+/-- One σ replacement entry.  `value` is already in the level world of the
+artifact being restored (`instL`-spliced by the caller for recursor-world
+artifacts). -/
+structure RestoreEntry where
+  aux : Name
+  np : Nat
+  value : VExpr
+  deriving DecidableEq
+
+def findRestoreCtor (entries : List RestoreEntry) (c : Name) :
+    Option (RestoreEntry × Name) :=
+  entries.findSome? fun entry =>
+    if entry.aux.isPrefixOf c && c != entry.aux then
+      some (entry, c.replacePrefix entry.aux .anonymous)
+    else none
+
+/-- σ on one expression, bottom-up: a replacement fires at the innermost
+spine node where an auxiliary head has collected exactly its block-parameter
+count, and enclosing applications extend the already-restored value.  On
+generated artifacts — where auxiliary constants are always applied to at
+least the block parameters and never occur inside another auxiliary spine's
+arguments — this coincides with `restoreNested`'s top-down
+replace-without-descending pass.  `recMap` renames auxiliary recursor
+constants and is consulted before the constructor-prefix case, exactly like
+`restoreNested`'s `auxRec` map. -/
+def restoreExpr (entries : List RestoreEntry) (recMap : List (Name × Name)) :
+    VExpr → VExpr
+  | .bvar i => .bvar i
+  | .sort l => .sort l
+  | .lam ty body => .lam (restoreExpr entries recMap ty) (restoreExpr entries recMap body)
+  | .forallE ty body =>
+      .forallE (restoreExpr entries recMap ty) (restoreExpr entries recMap body)
+  | .app f a =>
+      let e := VExpr.app (restoreExpr entries recMap f) (restoreExpr entries recMap a)
+      (restoreSpine e).getD e
+  | e@(.const ..) => (restoreSpine e).getD e
+  where
+  /-- Fire one replacement at a completed spine.  The head constant is
+  still unrestored exactly when no inner node completed its parameter
+  count. -/
+  restoreSpine (e : VExpr) : Option VExpr :=
+    match VExpr.appHead e with
+    | .const c ls =>
+      let args := e.appArgs []
+      match recMap.find? (·.1 == c) with
+      | some (_, newName) =>
+          if args.isEmpty then some (VExpr.const newName ls) else none
+      | none =>
+      match entries.find? (·.aux == c) with
+      | some entry =>
+          if args.length == entry.np then
+            some (instRevParams entry.value args)
+          else none
+      | none =>
+      match findRestoreCtor entries c with
+      | some (entry, suffix) =>
+          if args.length == entry.np then
+            let value := instRevParams entry.value args
+            match VExpr.appHead value with
+            | .const iname ils =>
+                some ((VExpr.const (iname ++ suffix) ils).appN (value.appArgs []))
+            | _ => none
+          else none
+      | none => none
+    | _ => none
+
+namespace NestedBlockChecked
+
+variable {source : VInductDecl}
+
+/-- The main family name owning the restored recursor inventory. -/
+def mainName (nested : NestedBlockChecked source) : Name :=
+  match source.types with
+  | ty :: _ => ty.name
+  | [] => .anonymous
+
+/-- Auxiliary recursor renaming: the `i`-th auxiliary family's recursor
+becomes `mainName.rec_(i+1)`, matching `mkAuxRecNameMap`. -/
+def recMap (nested : NestedBlockChecked source) : List (Name × Name) :=
+  nested.elim.specs.mapIdx fun i spec =>
+    (.str spec.aux "rec", ((.str nested.mainName "rec" : Name)).appendIndexAfter (i + 1))
+
+/-- σ entries in declaration level-world (constructor-type restorations). -/
+def declEntries (nested : NestedBlockChecked source) : List RestoreEntry :=
+  nested.elim.specs.map fun spec =>
+    ⟨spec.aux, source.nparams, spec.value⟩
+
+/-- σ entries spliced into recursor level-world by the elimination
+offset. -/
+def recEntries (nested : NestedBlockChecked source) : List RestoreEntry :=
+  nested.elim.specs.map fun spec =>
+    ⟨spec.aux, source.nparams,
+      spec.value.instL (VLevel.params' source.uvars
+        (nested.generation.recUvars - source.uvars))⟩
+
+/-- σ on a recursor-world artifact. -/
+def restoreRec (nested : NestedBlockChecked source) (e : VExpr) : VExpr :=
+  restoreExpr nested.recEntries nested.recMap e
+
+/-- The restored recursor inventory: the flattened block's recursors with
+auxiliary names renamed and every type restored.  Source-family recursors
+keep their `.str name "rec"` names. -/
+def recursors (nested : NestedBlockChecked source) : List VConstVal :=
+  nested.generation.recursors.map fun r =>
+    ⟨⟨r.uvars, nested.restoreRec r.type⟩,
+      ((nested.recMap.find? (·.1 == r.name)).map (·.2)).getD r.name⟩
+
+/-- The restored rule inventory, in the flattened block's globally ordered
+rule order. -/
+def generatedRules (nested : NestedBlockChecked source) : List VDefEq :=
+  nested.generation.generatedRules.map fun df =>
+    { df with
+        lhs := nested.restoreRec df.lhs
+        rhs := nested.restoreRec df.rhs
+        type := nested.restoreRec df.type }
+
+end NestedBlockChecked
+
+end VInductDecl
+
+/-- The nested transaction: the four-phase shape of
+`addInductBlockGeneration` with the *source* families and constructors as
+the stored payload and the *restored* recursors and rules as the generated
+artifacts.  No auxiliary constant enters the environment. -/
+def VEnv.addInductNested {source : VInductDecl} (env : VEnv)
+    (nested : source.NestedBlockChecked) : Option VEnv := do
+  let env ← source.blockTypeConstants.foldlM
+    (fun env type => env.addConst type.name type.toVConstant) env
+  let env ← source.blockConstructorConstants.foldlM
+    (fun env constructor => env.addConst constructor.name constructor.toVConstant) env
+  let env ← nested.recursors.foldlM
+    (fun env recursor => env.addConst recursor.name recursor.toVConstant) env
+  return nested.generatedRules.foldl VEnv.addDefEq env
+
+namespace VInductDecl
+
+/-- Chained constant well-formedness along an `addConst` fold: each
+constant is well formed in the environment already holding every earlier
+one. -/
+def NestedConstsWF (env : VEnv) : List VConstVal → Prop
+  | [] => True
+  | c :: cs => c.toVConstant.WF env ∧
+      ∀ env', env.addConst c.name c.toVConstant = some env' →
+        NestedConstsWF env' cs
+
+/-- Chained rule well-formedness along an `addDefEq` fold. -/
+def NestedRulesWF (env : VEnv) : List VDefEq → Prop
+  | [] => True
+  | df :: dfs => df.WF env ∧ NestedRulesWF (env.addDefEq df) dfs
+
+/-- Semantic input to nested preservation: the four transaction phases are
+well formed at their exact insertion environments.  The phase environments
+are determined by the deterministic constant folds, so each later field
+takes the earlier folds as hypotheses; a fixture discharges them by
+computation.  Inhabiting this package from the flattened block's staged
+semantic certificate is the σ-transport route recorded by the L4L-09A
+design note; fixtures may equally inhabit it from direct checker
+executions on the restored artifacts. -/
+structure NestedBlockChecked.WF {source : VInductDecl}
+    (nested : NestedBlockChecked source) (env : VEnv) : Prop where
+  types : NestedConstsWF env source.blockTypeConstants
+  ctors : ∀ {typeEnv},
+    source.blockTypeConstants.foldlM
+      (fun env type => env.addConst type.name type.toVConstant) env =
+        some typeEnv →
+    NestedConstsWF typeEnv source.blockConstructorConstants
+  recs : ∀ {typeEnv ctorEnv},
+    source.blockTypeConstants.foldlM
+      (fun env type => env.addConst type.name type.toVConstant) env =
+        some typeEnv →
+    source.blockConstructorConstants.foldlM
+      (fun env constructor => env.addConst constructor.name constructor.toVConstant)
+      typeEnv = some ctorEnv →
+    NestedConstsWF ctorEnv nested.recursors
+  rules : ∀ {typeEnv ctorEnv recEnv},
+    source.blockTypeConstants.foldlM
+      (fun env type => env.addConst type.name type.toVConstant) env =
+        some typeEnv →
+    source.blockConstructorConstants.foldlM
+      (fun env constructor => env.addConst constructor.name constructor.toVConstant)
+      typeEnv = some ctorEnv →
+    nested.recursors.foldlM
+      (fun env recursor => env.addConst recursor.name recursor.toVConstant)
+      ctorEnv = some recEnv →
+    NestedRulesWF recEnv nested.generatedRules
+
+end VInductDecl
+
+/-- Exact phase boundaries of a successful nested transaction. -/
+structure VEnv.AddInductNestedTrace {source : VInductDecl}
+    (env env' : VEnv) (nested : source.NestedBlockChecked) where
+  typeEnv : VEnv
+  ctorEnv : VEnv
+  recEnv : VEnv
+  addTypes :
+    source.blockTypeConstants.foldlM
+      (fun env type => env.addConst type.name type.toVConstant) env =
+        some typeEnv
+  addCtors :
+    source.blockConstructorConstants.foldlM
+      (fun env constructor => env.addConst constructor.name constructor.toVConstant)
+      typeEnv = some ctorEnv
+  addRecs :
+    nested.recursors.foldlM
+      (fun env recursor => env.addConst recursor.name recursor.toVConstant)
+      ctorEnv = some recEnv
+  addRules :
+    nested.generatedRules.foldl VEnv.addDefEq recEnv = env'
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/NestedInductiveFixtures.lean b/Lean4Lean/Theory/NestedInductiveFixtures.lean
new file mode 100644
index 00000000..4bcbd0e6
--- /dev/null
+++ b/Lean4Lean/Theory/NestedInductiveFixtures.lean
@@ -0,0 +1,323 @@
+import Lean4Lean.Theory.NestedInductive
+
+/-!
+# Nested flattening fixtures (L4L-09B)
+
+Executable pins for `nestedElimination?` on the two ladder fixtures — a
+universe-polymorphic rose tree through `List` and a nested indexed family
+through a `PVec`-style vector — plus the nearest structural rejections.
+Every family, constructor, auxiliary specification, and acceptance bit is
+compared against a hand-written expected descriptor.  The kernel
+differential for the same shapes lives in
+`Lean4Lean/Verify/Environment/NestedTransformation.lean`.
+-/
+
+namespace Lean4Lean.NestedInductiveFixtures
+
+open VInductDecl
+
+/-! ## Target blocks
+
+Hand-written copies of the nested-into metadata, in each block's own
+universe parameters; the Verify differential checks the same shapes
+against Lean's stored metadata. -/
+
+/-- `List` as a nested target: one family, one parameter. -/
+def listTarget : NestedTargetBlock where
+  nparams := 1
+  families :=
+    [{ name := `List
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.app (.const `List [.param 0]) (.bvar 0))⟩, `List.nil⟩,
+          ⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+                 (.app (.const `List [.param 0]) (.bvar 2))))⟩, `List.cons⟩] }]
+
+/-- A `PVec`-style indexed vector as a nested target: one parameter, one
+`Nat` index, indices spelled with `Nat.zero`/`Nat.succ`. -/
+def pvecTarget : NestedTargetBlock where
+  nparams := 1
+  families :=
+    [{ name := `PVec
+       uvars := 0
+       type := .forallE (.sort (.succ .zero))
+         (.forallE (.const `Nat []) (.sort (.succ .zero)))
+       ctors :=
+         [⟨⟨0, .forallE (.sort (.succ .zero))
+             (.app (.app (.const `PVec []) (.bvar 0)) (.const `Nat.zero []))⟩,
+           `PVec.nil⟩,
+          ⟨⟨0, .forallE (.sort (.succ .zero))
+             (.forallE (.bvar 0)
+               (.forallE (.const `Nat [])
+                 (.forallE (.app (.app (.const `PVec []) (.bvar 2)) (.bvar 0))
+                   (.app (.app (.const `PVec []) (.bvar 3))
+                     (.app (.const `Nat.succ []) (.bvar 1))))))⟩,
+           `PVec.cons⟩] }]
+
+/-! ## Rose tree through `List` -/
+
+def roseAux : Lean.Name := (`_nested ++ `List).appendIndexAfter 1
+
+/-- `inductive Rose (α : Type u) | node : α → List (Rose α) → Rose α` -/
+def roseSource : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := `Rose
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const `List [.param 0])
+                   (.app (.const `Rose [.param 0]) (.bvar 1)))
+                 (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] }]
+
+/-- The expected flattened rose block: the rewritten source family plus one
+auxiliary family, exactly the shapes pinned against the kernel by the
+L4L-09A probes. -/
+def roseFlat : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := `Rose
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const roseAux [.param 0]) (.bvar 1))
+                 (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] },
+     { name := roseAux
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.app (.const roseAux [.param 0]) (.bvar 0))⟩, roseAux ++ `nil⟩,
+          ⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.app (.const `Rose [.param 0]) (.bvar 0))
+               (.forallE (.app (.const roseAux [.param 0]) (.bvar 1))
+                 (.app (.const roseAux [.param 0]) (.bvar 2))))⟩,
+           roseAux ++ `cons⟩] }]
+
+/-- The expected auxiliary specification: `List (Rose α)`, open over the
+block parameter. -/
+def roseSpec : NestedAuxSpec where
+  aux := roseAux
+  target := `List
+  levels := [.param 0]
+  values := [.app (.const `Rose [.param 0]) (.bvar 0)]
+
+def roseElim? : Option (NestedElimination roseSource) :=
+  nestedElimination? [listTarget] roseSource
+
+#guard roseElim?.isSome
+#guard (roseElim?.map fun elim => elim.flat == roseFlat).getD false
+#guard (roseElim?.map fun elim => elim.specs == [roseSpec]).getD false
+#guard (roseElim?.map (·.numNested)).getD 0 == 1
+#guard roseFlat.stage3
+#guard nestedStage3 [listTarget] roseSource
+-- acceptance behavior of the raw analyzers on the source is unchanged
+#guard !roseSource.stage3
+
+/-! ## Nested indexed family through `PVec` -/
+
+def nvAux : Lean.Name := (`_nested ++ `PVec).appendIndexAfter 1
+
+/-- `inductive NV | node : (n : Nat) → PVec NV n → NV` -/
+def nvSource : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `NV
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const `Nat [])
+             (.forallE (.app (.app (.const `PVec []) (.const `NV []))
+                 (.bvar 0))
+               (.const `NV []))⟩, `NV.node⟩] }]
+
+/-- The expected flattened indexed block: the auxiliary family keeps the
+`Nat` index, its `nil` instantiates the index at `Nat.zero`, and its
+`cons` retains sibling recursion through `NV` plus the successor index. -/
+def nvFlat : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `NV
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const `Nat [])
+             (.forallE (.app (.const nvAux []) (.bvar 0))
+               (.const `NV []))⟩, `NV.node⟩] },
+     { name := nvAux
+       uvars := 0
+       type := .forallE (.const `Nat []) (.sort (.succ .zero))
+       ctors :=
+         [⟨⟨0, .app (.const nvAux []) (.const `Nat.zero [])⟩, nvAux ++ `nil⟩,
+          ⟨⟨0, .forallE (.const `NV [])
+             (.forallE (.const `Nat [])
+               (.forallE (.app (.const nvAux []) (.bvar 0))
+                 (.app (.const nvAux [])
+                   (.app (.const `Nat.succ []) (.bvar 1)))))⟩,
+           nvAux ++ `cons⟩] }]
+
+/-- The expected specification: the closed partial application `PVec NV`;
+the index argument stays behind on each occurrence. -/
+def nvSpec : NestedAuxSpec where
+  aux := nvAux
+  target := `PVec
+  levels := []
+  values := [.const `NV []]
+
+def nvElim? : Option (NestedElimination nvSource) :=
+  nestedElimination? [pvecTarget] nvSource
+
+#guard nvElim?.isSome
+#guard (nvElim?.map fun elim => elim.flat == nvFlat).getD false
+#guard (nvElim?.map fun elim => elim.specs == [nvSpec]).getD false
+#guard nvFlat.stage3
+#guard nestedStage3 [pvecTarget] nvSource
+#guard !nvSource.stage3
+
+/-! ## Nearest structural rejections -/
+
+/-- A parametric argument mentioning a constructor-local binder:
+`node : (n : Nat) → List (Loose n) → Loose` — the kernel's "parameters
+cannot contain local variables" class.  Flattening itself rejects. -/
+def looseSource : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `Loose
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const `Nat [])
+             (.forallE (.app (.const `List [.zero])
+                 (.app (.const `Loose []) (.bvar 0)))
+               (.const `Loose []))⟩, `Loose.node⟩] }]
+
+#guard (nestedElimination? [listTarget] looseSource).isNone
+#guard !nestedStage3 [listTarget] looseSource
+
+/-- A well-scoped but ill-shaped parametric argument:
+`node : Bad → List (Bad Nat.zero) → Bad` flattens, but the auxiliary
+constructor then mentions `Bad` applied off the parameter spine, which the
+unchanged block analyzer rejects. -/
+def badAppSource : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `Bad
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const `Bad [])
+             (.forallE (.app (.const `List [.zero])
+                 (.app (.const `Bad []) (.const `Nat.zero [])))
+               (.const `Bad []))⟩, `Bad.node⟩] }]
+
+#guard (nestedElimination? [listTarget] badAppSource).isSome
+#guard !nestedStage3 [listTarget] badAppSource
+
+-- Without the `List` target metadata the occurrence is not recognized,
+-- the flattened block is the source itself, and the unchanged analyzer
+-- rejects the under-a-foreign-head family mention.
+#guard (nestedElimination? [] roseSource).isSome
+#guard ((nestedElimination? [] roseSource).map
+  fun elim => elim.flat == roseSource && elim.specs == []).getD false
+#guard !nestedStage3 [] roseSource
+
+/-- A source family occupying the first canonical auxiliary name collides
+with the created auxiliary family; `blockNamesOK` rejects the flattened
+block exactly where the kernel's `checkName` rejects its own duplicate
+insertion. -/
+def collisionSource : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := `Rose
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const `List [.param 0])
+                   (.app (.const `Rose [.param 0]) (.bvar 1)))
+                 (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] },
+     { name := (`_nested ++ `List).appendIndexAfter 1
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors := [] }]
+
+#guard (nestedElimination? [listTarget] collisionSource).isSome
+#guard !nestedStage3 [listTarget] collisionSource
+
+/-! ## Restoration pins (L4L-09C)
+
+Structural pins for the restored generation artifacts; the exact
+comparison against Lean's stored recursor types and rule RHSs lives in the
+Verify differential. -/
+
+def roseNested? : Option (NestedBlockChecked roseSource) :=
+  nestedBlockChecked? [listTarget] roseSource
+
+def nvNested? : Option (NestedBlockChecked nvSource) :=
+  nestedBlockChecked? [pvecTarget] nvSource
+
+#guard roseNested?.isSome
+#guard nvNested?.isSome
+
+-- the restored recursor inventory: one per source family plus one per
+-- auxiliary family, on the main family's `appendIndexAfter` names
+#guard (roseNested?.map fun n => n.recursors.map (·.name)).getD [] ==
+  [`Rose.rec, ((.str `Rose "rec" : Lean.Name)).appendIndexAfter 1]
+#guard (nvNested?.map fun n => n.recursors.map (·.name)).getD [] ==
+  [`NV.rec, ((.str `NV "rec" : Lean.Name)).appendIndexAfter 1]
+
+def roseAuxConsts : List Lean.Name :=
+  [roseAux, roseAux ++ `nil, roseAux ++ `cons, .str roseAux "rec"]
+
+def nvAuxConsts : List Lean.Name :=
+  [nvAux, nvAux ++ `nil, nvAux ++ `cons, .str nvAux "rec"]
+
+/-- No auxiliary constant survives restoration in any recursor type or
+rule component. -/
+def restoredClean {source : VInductDecl} (auxConsts : List Lean.Name)
+    (nested : NestedBlockChecked source) : Bool :=
+  nested.recursors.all (fun r => !VExpr.hasAnyConst auxConsts r.type) &&
+    nested.generatedRules.all fun df =>
+      !VExpr.hasAnyConst auxConsts df.lhs &&
+        !VExpr.hasAnyConst auxConsts df.rhs &&
+        !VExpr.hasAnyConst auxConsts df.type
+
+#guard (roseNested?.map (restoredClean roseAuxConsts)).getD false
+#guard (nvNested?.map (restoredClean nvAuxConsts)).getD false
+
+-- the globally flattened rule inventory: one node rule plus the two
+-- restored `List`/`PVec` rules
+#guard (roseNested?.map fun n => n.generatedRules.length).getD 0 == 3
+#guard (nvNested?.map fun n => n.generatedRules.length).getD 0 == 3
+
+-- the nested transaction inserts the source payload and the restored
+-- recursors, and no auxiliary constant
+def roseNestedEnv? : Option VEnv := do
+  VEnv.empty.addInductNested (← roseNested?)
+
+#guard roseNestedEnv?.isSome
+#guard (roseNestedEnv?.map fun env =>
+  (env.constants `Rose).isSome && (env.constants `Rose.node).isSome &&
+    (env.constants `Rose.rec).isSome &&
+    (env.constants (((.str `Rose "rec" : Lean.Name)).appendIndexAfter 1)).isSome &&
+    (env.constants roseAux).isNone &&
+    (env.constants (roseAux ++ `cons)).isNone &&
+    (env.constants (.str roseAux "rec")).isNone).getD false
+
+end Lean4Lean.NestedInductiveFixtures
diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean
new file mode 100644
index 00000000..771d9e85
--- /dev/null
+++ b/Lean4Lean/Theory/Projection.lean
@@ -0,0 +1,3542 @@
+import Lean4Lean.Theory.Typing.InductivePatternWF
+
+/-!
+# Structure projections
+
+This module is the consumer-neutral projection boundary.  A projection is
+not determined by a structure name and field number alone: universe
+instantiations, parameters, the constructor telescope, and the generated
+recursor/iota package all affect its meaning.  `VStructureView` retains that
+data from the same checked artifact used by inductive generation.
+
+Projection terms are encoded with the generated recursor.  Earlier
+projections occur in the motive of a dependent later projection, so one view
+determines both the projected term and its dependent result type.  No
+projection-function name map or unconstrained metadata witness is involved.
+-/
+
+namespace Lean4Lean
+
+open VInductDecl
+
+/-- Instantiate an outermost-first argument list at a fixed offset.
+
+The `k` variables below the substituted telescope remain bound.  Each
+argument is lifted past them before it replaces the then-outermost variable.
+This is the operation needed to specialize constructor parameters while
+retaining the preceding dependent fields. -/
+def VExpr.instRevAt : VExpr → List VExpr → Nat → VExpr
+  | e, [], _ => e
+  | e, a :: as, k => instRevAt (e.inst a (k + as.length)) as k
+
+theorem VExpr.instRevAt_zero (e : VExpr) (args : List VExpr) :
+    e.instRevAt args 0 = e.instRev args := by
+  induction args generalizing e with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [VExpr.instRevAt, VExpr.instRev]
+      simpa using ih (e := e.inst arg args.length)
+
+private theorem VExpr.instRevAt_closedN (args : List VExpr)
+    {C : VExpr} {k : Nat} (hC : C.ClosedN k) :
+    C.instRevAt args k = C := by
+  induction args generalizing C with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [VExpr.instRevAt]
+      rw [hC.instN_eq (by omega)]
+      exact ih hC
+
+private theorem VExpr.instRev_forallE_projection
+    (A B : VExpr) (args : List VExpr) :
+    VExpr.instRev (.forallE A B) args =
+      .forallE (VExpr.instRev A args)
+        (VExpr.instRevAt B args 1) := by
+  induction args generalizing A B with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [VExpr.instRev, VExpr.inst]
+      rw [ih]
+      congr 1
+      simp only [VExpr.instRevAt]
+      rw [show 1 + args.length = args.length + 1 by omega]
+
+private theorem VExpr.instRevAt_forallE_projection
+    (A B : VExpr) (args : List VExpr) (k : Nat) :
+    VExpr.instRevAt (.forallE A B) args k =
+      .forallE (VExpr.instRevAt A args k)
+        (VExpr.instRevAt B args (k + 1)) := by
+  induction args generalizing A B with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [VExpr.instRevAt, VExpr.inst]
+      rw [ih]
+      congr 1
+      rw [show k + args.length + 1 = k + 1 + args.length by omega]
+
+private theorem VExpr.instRevAt_forallN_projection
+    (As : List VExpr) (B : VExpr) (args : List VExpr) (k : Nat) :
+    VExpr.instRevAt (VExpr.forallN As B) args k =
+      VExpr.forallN
+        (As.zipIdx k |>.map fun x => x.1.instRevAt args x.2)
+        (B.instRevAt args (k + As.length)) := by
+  induction As generalizing k with
+  | nil => rfl
+  | cons A As ih =>
+      simp only [VExpr.forallN, VExpr.instRevAt_forallE_projection,
+        List.zipIdx, List.map_cons, List.length_cons]
+      rw [ih]
+      rw [show k + 1 + As.length = k + (As.length + 1) by omega]
+
+theorem VExpr.instRev_forallN_projection
+    (As : List VExpr) (B : VExpr) (args : List VExpr) :
+    VExpr.instRev (VExpr.forallN As B) args =
+      VExpr.forallN
+        (As.zipIdx.map fun x => x.1.instRevAt args x.2)
+        (B.instRevAt args As.length) := by
+  cases As with
+  | nil => simp [VExpr.forallN, VExpr.instRevAt_zero]
+  | cons A As =>
+      simp only [VExpr.forallN, VExpr.instRev_forallE_projection,
+        List.zipIdx, List.map_cons, List.length_cons]
+      rw [VExpr.instRevAt_forallN_projection]
+      rw [VExpr.instRevAt_zero]
+      congr 2
+      rw [Nat.add_comm]
+
+/-- Consume a syntactic prefix of dependent `forall` binders, instantiating
+them outermost-first. -/
+def VExpr.consumeForalls? : VExpr → List VExpr → Option VExpr
+  | e, [] => some e
+  | .forallE _ body, arg :: args => consumeForalls? (body.inst arg) args
+  | _, _ :: _ => none
+
+theorem VExpr.consumeForalls?_append (e : VExpr)
+    (left right : List VExpr) :
+    e.consumeForalls? (left ++ right) =
+      (e.consumeForalls? left).bind fun cursor =>
+        cursor.consumeForalls? right := by
+  induction left generalizing e with
+  | nil => rfl
+  | cons arg left ih =>
+      cases e <;> simp [VExpr.consumeForalls?, ih]
+
+theorem VExpr.instTelN_getElem? (arg : VExpr) (fields : List VExpr)
+    (k i : Nat) :
+    (VExpr.instTelN arg fields k)[i]? =
+      fields[i]?.map fun field => field.inst arg (k + i) := by
+  induction fields generalizing k i with
+  | nil => simp [VExpr.instTelN]
+  | cons field fields ih =>
+      cases i with
+      | zero => simp [VExpr.instTelN]
+      | succ i =>
+          simp only [VExpr.instTelN, List.getElem?_cons_succ]
+          simpa only [Nat.add_assoc, Nat.add_comm,
+            Nat.add_left_comm] using ih (k + 1) i
+
+/-- Consuming `args` from a telescope exposes the next original binder with
+exactly those arguments substituted. -/
+theorem VExpr.consumeForalls?_forallN_domain
+    (fields : List VExpr) (result : VExpr) (args : List VExpr)
+    (hlen : args.length < fields.length) :
+    ∃ field body,
+      fields[args.length]? = some field ∧
+      VExpr.consumeForalls? (VExpr.forallN fields result) args =
+        some (.forallE (field.instRevAt args 0) body) := by
+  induction args generalizing fields result with
+  | nil =>
+      cases fields with
+      | nil => simp at hlen
+      | cons field fields =>
+          exact ⟨field, VExpr.forallN fields result, rfl, rfl⟩
+  | cons arg args ih =>
+      cases fields with
+      | nil => simp at hlen
+      | cons field fields =>
+          have hlen' : args.length <
+              (VExpr.instTelN arg fields 0).length := by
+            simpa [VExpr.instTelN_length] using hlen
+          obtain ⟨field', body, hfield', hconsume⟩ :=
+            ih (VExpr.instTelN arg fields 0)
+              (result.inst arg fields.length) hlen'
+          rw [VExpr.instTelN_getElem?] at hfield'
+          obtain ⟨original, horiginal, rfl⟩ := Option.map_eq_some_iff.1 hfield'
+          refine ⟨original, body, by simpa using horiginal, ?_⟩
+          simp only [VExpr.forallN, VExpr.consumeForalls?,
+            VExpr.instN_forallN]
+          simp only [Nat.zero_add]
+          simpa only [VExpr.instRevAt, Nat.zero_add] using hconsume
+
+@[simp] theorem VExpr.instL_instRevAt (e : VExpr) (as : List VExpr)
+    (k : Nat) :
+    (e.instRevAt as k).instL ls =
+      (e.instL ls).instRevAt (as.map (VExpr.instL ls)) k := by
+  induction as generalizing e with
+  | nil => rfl
+  | cons a as ih =>
+      simp only [VExpr.instRevAt, List.map_cons]
+      simpa only [VExpr.instL_instN, List.length_map] using
+        ih (e := e.inst a (k + as.length))
+
+private theorem VExpr.instL_lamN_projection (ls : List VLevel) :
+    ∀ (As : List VExpr) (e : VExpr),
+      (VExpr.lamN As e).instL ls =
+        VExpr.lamN (As.map (VExpr.instL ls)) (e.instL ls)
+  | [], _ => rfl
+  | _ :: As, e => by
+      simp only [VExpr.lamN, VExpr.instL, List.map_cons]
+      rw [VExpr.instL_lamN_projection ls As e]
+
+private theorem VExpr.liftN_lamN_projection (n : Nat) :
+    ∀ (As : List VExpr) (e : VExpr) (k : Nat),
+      (VExpr.lamN As e).liftN n k =
+        VExpr.lamN (VExpr.liftTelN n As k)
+          (e.liftN n (k + As.length))
+  | [], _, _ => rfl
+  | _ :: As, e, k => by
+      simp only [VExpr.lamN, VExpr.liftN, VExpr.liftTelN,
+        List.length_cons]
+      rw [VExpr.liftN_lamN_projection n As e (k + 1)]
+      rw [show k + 1 + As.length = k + (As.length + 1) by omega]
+
+private theorem VExpr.instN_lamN_projection (a : VExpr) :
+    ∀ (As : List VExpr) (e : VExpr) (k : Nat),
+      (VExpr.lamN As e).inst a k =
+        VExpr.lamN (VExpr.instTelN a As k)
+          (e.inst a (k + As.length))
+  | [], _, _ => rfl
+  | _ :: As, e, k => by
+      simp only [VExpr.lamN, VExpr.inst, VExpr.instTelN,
+        List.length_cons]
+      rw [VExpr.instN_lamN_projection a As e (k + 1)]
+      rw [show k + 1 + As.length = k + (As.length + 1) by omega]
+
+private theorem VExpr.liftN_lift_projection (e : VExpr) (n k : Nat) :
+    e.lift.liftN n (k + 1) = (e.liftN n k).lift :=
+  (VExpr.lift_liftN' e k).symm
+
+private theorem VExpr.liftN_liftAt_projection
+    (e : VExpr) (n k i : Nat) :
+    (e.liftN 1 i).liftN n (k + 1 + i) =
+      (e.liftN n (k + i)).liftN 1 i := by
+  symm
+  simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using
+    VExpr.liftN_liftN_comm e 1 n i (k + i) (by omega)
+
+private theorem VExpr.liftTelN_liftAt_projection (As : List VExpr)
+    (n k i : Nat) :
+    VExpr.liftTelN n (VExpr.liftTelN 1 As i) (k + 1 + i) =
+      VExpr.liftTelN 1 (VExpr.liftTelN n As (k + i)) i := by
+  induction As generalizing i with
+  | nil => rfl
+  | cons A As ih =>
+      simp only [VExpr.liftTelN]
+      rw [VExpr.liftN_liftAt_projection A n k i]
+      congr 1
+      simpa only [Nat.add_assoc] using ih (i + 1)
+
+private theorem VExpr.liftTelN_lift_projection (As : List VExpr)
+    (n k : Nat) :
+    VExpr.liftTelN n (VExpr.liftTelN 1 As 0) (k + 1) =
+      VExpr.liftTelN 1 (VExpr.liftTelN n As k) 0 := by
+  simpa using VExpr.liftTelN_liftAt_projection As n k 0
+
+private theorem VExpr.instN_liftAt_projection
+    (e a : VExpr) (k i : Nat) :
+    (e.liftN 1 i).inst a (k + 1 + i) =
+      (e.inst a (k + i)).liftN 1 i := by
+  symm
+  simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using
+    VExpr.liftN_instN_lo 1 e a (k + i) i (by omega)
+
+private theorem VExpr.instTelN_liftAt_projection (As : List VExpr)
+    (a : VExpr) (k i : Nat) :
+    VExpr.instTelN a (VExpr.liftTelN 1 As i) (k + 1 + i) =
+      VExpr.liftTelN 1 (VExpr.instTelN a As (k + i)) i := by
+  induction As generalizing i with
+  | nil => rfl
+  | cons A As ih =>
+      simp only [VExpr.liftTelN, VExpr.instTelN]
+      rw [VExpr.instN_liftAt_projection A a k i]
+      congr 1
+      simpa only [Nat.add_assoc] using ih (i + 1)
+
+private theorem VExpr.instTelN_lift_projection (As : List VExpr)
+    (a : VExpr) (k : Nat) :
+    VExpr.instTelN a (VExpr.liftTelN 1 As 0) (k + 1) =
+      VExpr.liftTelN 1 (VExpr.instTelN a As k) 0 := by
+  simpa using VExpr.instTelN_liftAt_projection As a k 0
+
+private theorem VExpr.instN_instRevAt_lift_projection
+    (e : VExpr) (args : List VExpr) (a : VExpr) (i : Nat) :
+    ((e.liftN 1 i).instRevAt args (i + 1)).inst a i =
+      e.instRevAt args i := by
+  induction args generalizing e with
+  | nil => exact VExpr.inst_liftN1 e a i
+  | cons arg args ih =>
+      simp only [VExpr.instRevAt]
+      rw [show i + 1 + args.length = args.length + 1 + i by omega,
+        VExpr.instN_liftAt_projection e arg args.length i]
+      simpa only [Nat.add_comm] using
+        ih (e := e.inst arg (args.length + i))
+
+private theorem VExpr.instTelN_instRevAt_lift_projection
+    (fields : List VExpr) (args : List VExpr) (a : VExpr)
+    (start : Nat) :
+    VExpr.instTelN a
+        ((VExpr.liftTelN 1 fields start).zipIdx (start + 1) |>.map
+          fun x => x.1.instRevAt args x.2)
+        start =
+      (fields.zipIdx start |>.map
+        fun x => x.1.instRevAt args x.2) := by
+  induction fields generalizing start with
+  | nil => rfl
+  | cons field fields ih =>
+      simp only [VExpr.liftTelN, List.zipIdx, List.map_cons,
+        VExpr.instTelN]
+      rw [VExpr.instN_instRevAt_lift_projection]
+      congr 1
+      simpa only [Nat.add_assoc] using ih (start + 1)
+
+private theorem VExpr.inst_liftN_top (e a : VExpr) (n : Nat) :
+    (e.liftN (n + 1)).inst a n = e.liftN n := by
+  rw [← VExpr.liftN'_liftN' (e := e) (n1 := n) (n2 := 1)
+    (k1 := 0) (k2 := n) (Nat.zero_le _) (by omega)]
+  exact VExpr.inst_liftN (e.liftN n) a
+
+private theorem VExpr.instRevAt_liftN_len (args : List VExpr)
+    (e : VExpr) (k : Nat) :
+    (e.liftN (k + args.length)).instRevAt args k = e.liftN k := by
+  induction args with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [List.length_cons, VExpr.instRevAt]
+      rw [show k + (args.length + 1) = (k + args.length) + 1 by omega,
+        VExpr.inst_liftN_top]
+      exact ih
+
+private theorem VExpr.instRevAt_bvar_lt_cons (args : List VExpr)
+    (arg : VExpr) (k i : Nat) (hi : i < k + args.length) :
+    (VExpr.bvar i).instRevAt (arg :: args) k =
+      (VExpr.bvar i).instRevAt args k := by
+  simp only [VExpr.instRevAt]
+  congr 1
+  simp [VExpr.inst, VExpr.instVar, hi]
+
+private theorem VExpr.map_instRevAt_bvarRevRange
+    (args : List VExpr) (k : Nat) :
+    (VExpr.bvarRevRange k args.length).map
+        (fun e => e.instRevAt args k) =
+      args.map (VExpr.liftN k) := by
+  induction args with
+  | nil => rfl
+  | cons arg args ih =>
+      simp only [List.length_cons, VExpr.bvarRevRange,
+        List.map_cons]
+      congr 1
+      · simp only [VExpr.instRevAt]
+        rw [show (VExpr.bvar (k + args.length)).inst arg
+              (k + args.length) = arg.liftN (k + args.length) by
+            simp [VExpr.inst, VExpr.instVar]]
+        exact VExpr.instRevAt_liftN_len args arg k
+      · rw [← ih]
+        apply List.map_congr_left
+        intro e he
+        obtain ⟨i, rfl, _, hi⟩ := VExpr.mem_bvarRevRange he
+        exact VExpr.instRevAt_bvar_lt_cons args arg k i (by omega)
+
+private theorem VExpr.instRevAt_appN_projection
+    (f : VExpr) (es : List VExpr) (args : List VExpr) (k : Nat) :
+    (VExpr.appN f es).instRevAt args k =
+      VExpr.appN (f.instRevAt args k)
+        (es.map fun e => e.instRevAt args k) := by
+  induction args generalizing f es with
+  | nil => simp [VExpr.instRevAt, List.map_id']
+  | cons arg args ih =>
+      simp only [VExpr.instRevAt, VExpr.instN_appN]
+      rw [ih]
+      simp only [List.map_map, Function.comp_def, VExpr.instRevAt]
+
+private theorem VExpr.map_instRevAt_closedN (args es : List VExpr)
+    (k : Nat) (hclosed : ∀ e ∈ es, e.ClosedN k) :
+    es.map (fun e => e.instRevAt args k) = es := by
+  induction es with
+  | nil => rfl
+  | cons e es ih =>
+      simp only [List.map_cons]
+      rw [VExpr.instRevAt_closedN args (hclosed e (.head _))]
+      congr 1
+      exact ih (fun e he => hclosed e (.tail _ he))
+
+private theorem VExpr.map_instN_closedN (a : VExpr) (es : List VExpr)
+    (k : Nat) (hclosed : ∀ e ∈ es, e.ClosedN k) :
+    es.map (fun e => e.inst a k) = es := by
+  induction es with
+  | nil => rfl
+  | cons e es ih =>
+      simp only [List.map_cons]
+      rw [(hclosed e (.head _)).instN_eq (Nat.le_refl _)]
+      congr 1
+      exact ih (fun e he => hclosed e (.tail _ he))
+
+private theorem VExpr.map_instN_liftN_top
+    (es : List VExpr) (a : VExpr) (n : Nat) :
+    (es.map (VExpr.liftN (n + 1))).map
+        (fun e => e.inst a n) =
+      es.map (VExpr.liftN n) := by
+  rw [List.map_map]
+  apply List.map_congr_left
+  intro e _
+  exact VExpr.inst_liftN_top e a n
+
+private theorem VExpr.projectionMinorBody_shape
+    (constructorName : Name) (levels : List VLevel)
+    (params : List VExpr) (m : Nat) (typeFn : VExpr) :
+    ((VExpr.appN (.bvar m)
+          [VExpr.appN (.const constructorName levels)
+            (VExpr.bvarRevRange (m + 1) params.length ++
+              VExpr.bvarRevRange 0 m)]).instRevAt params (m + 1)).inst
+        typeFn m =
+      .app (typeFn.liftN m)
+        (VExpr.appN (.const constructorName levels)
+          (params.map (VExpr.liftN m) ++
+            VExpr.bvarRevRange 0 m)) := by
+  have hmotiveR : (VExpr.bvar m).instRevAt params (m + 1) =
+      .bvar m := VExpr.instRevAt_closedN params (by
+        exact Nat.lt_succ_self m)
+  have hconstR : (VExpr.const constructorName levels).instRevAt
+      params (m + 1) = .const constructorName levels :=
+    VExpr.instRevAt_closedN params (by trivial)
+  have hfieldsR := VExpr.map_instRevAt_closedN params
+    (VExpr.bvarRevRange 0 m) (m + 1)
+    (bvarRevRange_closedN m 0 (m + 1) (by omega))
+  have hmotiveI : (VExpr.bvar m).inst typeFn m =
+      typeFn.liftN m := by simp [VExpr.inst, VExpr.instVar]
+  have hconstI : (VExpr.const constructorName levels).inst typeFn m =
+      .const constructorName levels := by rfl
+  have hparamsI := VExpr.map_instN_liftN_top params typeFn m
+  have hfieldsI := VExpr.map_instN_closedN typeFn
+    (VExpr.bvarRevRange 0 m) m
+    (bvarRevRange_closedN m 0 m (by omega))
+  rw [VExpr.instRevAt_appN_projection, hmotiveR]
+  simp only [List.map_singleton]
+  rw [VExpr.instRevAt_appN_projection, hconstR, List.map_append,
+    VExpr.map_instRevAt_bvarRevRange, hfieldsR]
+  rw [VExpr.instN_appN, hmotiveI]
+  simp only [List.map_singleton]
+  rw [VExpr.instN_appN, hconstI, List.map_append,
+    hparamsI, hfieldsI]
+  rfl
+
+private theorem VExpr.projectionMajorTail_shape
+    (familyName : Name) (levels : List VLevel)
+    (params : List VExpr) (typeFn : VExpr) :
+    (((VExpr.forallE
+          (VExpr.appN (.const familyName levels)
+            (VExpr.bvarRevRange 2 params.length))
+          (.app (.appN (.bvar 2) []) (.bvar 0))).instRevAt
+        params 2).inst typeFn 1) =
+      VExpr.forallE
+        (VExpr.appN (.const familyName levels)
+          (params.map (VExpr.liftN 1)))
+        (.app (typeFn.liftN 2) (.bvar 0)) := by
+  have hconstR : (VExpr.const familyName levels).instRevAt
+      params 2 = .const familyName levels :=
+    VExpr.instRevAt_closedN params (by trivial)
+  have hbodyR :
+      (VExpr.app (VExpr.appN (.bvar 2) []) (.bvar 0)).instRevAt
+          params 3 =
+        VExpr.app (VExpr.appN (.bvar 2) []) (.bvar 0) :=
+    VExpr.instRevAt_closedN params (by
+      change 2 < 3 ∧ 0 < 3
+      omega)
+  rw [VExpr.instRevAt_forallE_projection,
+    VExpr.instRevAt_appN_projection, hconstR,
+    VExpr.map_instRevAt_bvarRevRange, hbodyR]
+  simp only [VExpr.inst]
+  congr 1
+  · rw [VExpr.instN_appN]
+    have hconstI : (VExpr.const familyName levels).inst typeFn 1 =
+        .const familyName levels := by rfl
+    rw [hconstI, VExpr.map_instN_liftN_top]
+
+theorem VExpr.liftN_instRevAt (e : VExpr) (as : List VExpr)
+    (i k n : Nat) :
+    (e.instRevAt as i).liftN n (k + i) =
+      (e.liftN n (k + i + as.length)).instRevAt
+        (as.map fun a => a.liftN n k) i := by
+  induction as generalizing e with
+  | nil => simp [VExpr.instRevAt]
+  | cons a as ih =>
+      simp only [VExpr.instRevAt, List.map_cons]
+      rw [ih]
+      simp only [List.length_cons, List.length_map]
+      rw [show k + i + as.length = k + (i + as.length) by omega,
+        VExpr.liftN_instN_hi]
+      congr 3 <;> omega
+
+theorem VExpr.instN_instRevAt (e : VExpr) (as : List VExpr)
+    (i k : Nat) (a : VExpr) :
+    (e.instRevAt as i).inst a (k + i) =
+      (e.inst a (k + i + as.length)).instRevAt
+        (as.map fun arg => arg.inst a k) i := by
+  induction as generalizing e with
+  | nil => simp [VExpr.instRevAt]
+  | cons arg as ih =>
+      simp only [VExpr.instRevAt, List.map_cons]
+      rw [ih]
+      simp only [List.length_cons, List.length_map]
+      rw [show k + i + as.length = k + (i + as.length) by omega,
+        VExpr.inst_inst_hi]
+      congr 3 <;> omega
+
+/-- A telescope whose entries have the exact retained sort levels. -/
+inductive VEnv.OnSortTel (env : VEnv) (U : Nat) :
+    List VExpr → List VExpr → List VLevel → Prop where
+  | nil : OnSortTel env U Γ [] []
+  | cons :
+      env.HasType U Γ A (.sort u) →
+      OnSortTel env U (A :: Γ) As us →
+      OnSortTel env U Γ (A :: As) (u :: us)
+
+private theorem onCtx_levelWFProjection {env : VEnv} {U : Nat} :
+    ∀ {Γ : List VExpr}, OnCtx Γ (env.IsType U) →
+      OnCtx Γ fun _ A => A.LevelWF U
+  | [], _ => trivial
+  | _ :: _, ⟨hΓ, ⟨_, hA⟩⟩ =>
+      let hΓ' := onCtx_levelWFProjection hΓ
+      ⟨hΓ', (hA.levelWF hΓ').1⟩
+
+/-- Every retained sort selected from a checked sort telescope is a
+well-formed universe at the ambient universe bound. -/
+theorem VEnv.OnSortTel.sortWF {env : VEnv} {U : Nat}
+    : ∀ {Γ : List VExpr} {As : List VExpr} {us : List VLevel},
+      OnCtx Γ (env.IsType U) → env.OnSortTel U Γ As us →
+      ∀ {i : Nat} {u : VLevel}, us[i]? = some u → u.WF U
+  | _, [], [], _, .nil, _, _, h => by simp at h
+  | _, _ :: _, _ :: _, hΓ, .cons hA hT, 0, _, h => by
+      injection h with h
+      subst h
+      exact (hA.levelWF (onCtx_levelWFProjection hΓ)).2.2
+  | Γ, A :: As, u₀ :: us, hΓ, .cons hA hT, i + 1, u, h => by
+      exact VEnv.OnSortTel.sortWF (env := env) (U := U)
+        (Γ := A :: Γ) (As := As) (us := us)
+        ⟨hΓ, ⟨u₀, hA⟩⟩ hT (by simpa using h)
+
+private theorem VEnv.OnTel.monoProjection {env env' : VEnv}
+    (henv : env ≤ env') (H : env.OnTel U Γ As) : env'.OnTel U Γ As := by
+  induction As generalizing Γ with
+  | nil => trivial
+  | cons _ _ ih =>
+      exact ⟨H.1.mono henv, ih H.2⟩
+
+theorem VEnv.OnSortTel.mono {env env' : VEnv} (henv : env ≤ env')
+    (H : env.OnSortTel U Γ As us) : env'.OnSortTel U Γ As us := by
+  induction H with
+  | nil => exact .nil
+  | cons hA _ ih => exact .cons (hA.mono henv) ih
+
+/-- Forget the retained sort labels, preserving the underlying telescope
+well-formedness judgment. -/
+theorem VEnv.OnSortTel.toOnTel {env : VEnv} :
+    ∀ {U : Nat} {Γ As : List VExpr} {us : List VLevel},
+      env.OnSortTel U Γ As us → env.OnTel U Γ As
+  | _, _, [], [], .nil => trivial
+  | _, _, _ :: _, _ :: _, .cons hA hT =>
+      ⟨⟨_, hA⟩, VEnv.OnSortTel.toOnTel hT⟩
+
+theorem VEnv.OnSortTel.instL {env : VEnv} {U U' : Nat}
+    (hlevels : ∀ level ∈ levels, level.WF U') :
+    ∀ {Γ As us}, env.OnSortTel U Γ As us →
+      env.OnSortTel U' (Γ.map (VExpr.instL levels))
+        (As.map (VExpr.instL levels))
+        (us.map (VLevel.inst levels))
+  | _, [], [], .nil => .nil
+  | _, _ :: _, _ :: _, .cons hA hT =>
+      .cons (hA.instL hlevels) (VEnv.OnSortTel.instL hlevels hT)
+
+theorem VEnv.OnSortTel.weakN {env : VEnv} (henv : env.Ordered)
+    {U n k : Nat} {Γ Γ' : List VExpr} (W : Ctx.LiftN n k Γ Γ') :
+    ∀ {As us}, env.OnSortTel U Γ As us →
+      env.OnSortTel U Γ' (VExpr.liftTelN n As k) us
+  | [], [], .nil => .nil
+  | _ :: _, _ :: _, .cons hA hT =>
+      .cons (hA.weakN henv W)
+        (VEnv.OnSortTel.weakN henv W.succ hT)
+
+private theorem VEnv.OnSortTel.instN {env : VEnv} (henv : env.Ordered)
+    {U : Nat} {Γ₀ : List VExpr} {e₀ A₀ : VExpr}
+    (h₀ : env.HasType U Γ₀ e₀ A₀) :
+    ∀ {As : List VExpr} {us : List VLevel} {k : Nat}
+      {Γ Γ' : List VExpr},
+      Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' →
+      env.OnSortTel U Γ As us →
+      env.OnSortTel U Γ' (VExpr.instTelN e₀ As k) us
+  | [], [], _, _, _, _, .nil => .nil
+  | _ :: _, _ :: _, _, _, _, W, .cons hA hT =>
+      .cons (hA.instN henv W h₀)
+        (VEnv.OnSortTel.instN henv h₀ W.succ hT)
+
+private theorem VExpr.instRevAt_instTelN_cons
+    (fields : List VExpr) (a : VExpr) (as : List VExpr) :
+    ((VExpr.instTelN a fields as.length).zipIdx.map fun (field, i) =>
+        VExpr.instRevAt field as i) =
+      (fields.zipIdx.map fun (field, i) =>
+        VExpr.instRevAt field (a :: as) i) := by
+  suffices ∀ (start k : Nat), k = as.length + start →
+      ((VExpr.instTelN a fields k).zipIdx start |>.map
+          fun (field, i) => VExpr.instRevAt field as i) =
+        (fields.zipIdx start |>.map fun (field, i) =>
+          VExpr.instRevAt field (a :: as) i) by
+    simpa using this 0 as.length (by omega)
+  intro start k hk
+  induction fields generalizing start k with
+  | nil => rfl
+  | cons field fields ih =>
+      simp only [VExpr.instTelN, List.zipIdx, List.map_cons,
+        VExpr.instRevAt]
+      rw [hk]
+      congr 1
+      · congr 2 <;> omega
+      · exact ih (start + 1) (as.length + start + 1) (by omega)
+
+theorem VExpr.instRevAt_map_instL_zipIdx
+    (fields : List VExpr) (levels : List VLevel)
+    (params : List VExpr) (start : Nat := 0) :
+    ((fields.map (VExpr.instL levels)).zipIdx start |>.map
+        fun (field, i) => VExpr.instRevAt field params i) =
+      (fields.zipIdx start |>.map fun (field, i) =>
+        VExpr.instRevAt (field.instL levels) params i) := by
+  induction fields generalizing start with
+  | nil => rfl
+  | cons field fields ih =>
+      simp only [List.map_cons, List.zipIdx]
+      congr 1
+      exact ih (start + 1)
+
+private theorem VEnv.OnSortTel.instRevParams {env : VEnv}
+    (henv : env.Ordered) {U : Nat} :
+    ∀ {Γ params args fields sorts resultLevel},
+      env.SpineWF U Γ (VExpr.forallN params (.sort resultLevel))
+        args (.sort resultLevel) →
+      args.length = params.length →
+      env.OnSortTel U (params.reverse ++ Γ) fields sorts →
+      env.OnSortTel U Γ
+        (fields.zipIdx.map fun (field, i) =>
+          VExpr.instRevAt field args i) sorts
+  | _, [], [], fields, sorts, _, hspine, _, hfields => by
+      simpa [VExpr.instRevAt] using hfields
+  | _, [], _ :: _, _, _, _, _, hlen, _ => by simp at hlen
+  | Γ, param :: params, arg :: args, fields, sorts, resultLevel,
+      .cons harg hrest, hlen, hfields => by
+      have hparams : args.length = params.length := by simpa using hlen
+      have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := arg)
+        (A₀ := param) params (.zero)
+      have hfields' : env.OnSortTel U
+          ((VExpr.instTelN arg params 0).reverse ++ Γ)
+          (VExpr.instTelN arg fields params.length) sorts := by
+        apply VEnv.OnSortTel.instN henv harg W
+        simpa [List.append_assoc] using hfields
+      have hrest' : env.SpineWF U Γ
+          (VExpr.forallN (VExpr.instTelN arg params 0)
+            (.sort resultLevel)) args (.sort resultLevel) := by
+        simpa [VExpr.instN_forallN, VExpr.inst] using hrest
+      have hout := VEnv.OnSortTel.instRevParams henv
+        hrest' (by simpa [VExpr.instTelN_length] using hparams) hfields'
+      rw [← hparams, VExpr.instRevAt_instTelN_cons] at hout
+      exact hout
+
+/-- Extend a well-formed ambient context by a well-formed telescope. -/
+theorem VEnv.OnTel.toOnCtx {env : VEnv} {U : Nat} :
+    ∀ {As Γ}, env.OnTel U Γ As → OnCtx Γ (env.IsType U) →
+      OnCtx (As.reverse ++ Γ) (env.IsType U)
+  | [], _, _, hΓ => by simpa using hΓ
+  | A :: As, Γ, ⟨hA, hAs⟩, hΓ => by
+      simpa [List.append_assoc] using
+        VEnv.OnTel.toOnCtx hAs (Γ := A :: Γ) ⟨hΓ, hA⟩
+
+private theorem VEnv.OnSortTel.closedAt {env : VEnv} {U : Nat}
+    (henv : env.Ordered) :
+    ∀ {As us Γ}, env.OnSortTel U Γ As us → CtxClosed Γ →
+      ∀ {i : Nat} {field : VExpr}, As[i]? = some field →
+        field.ClosedN (Γ.length + i)
+  | _, _, _, .nil, _, i, _, h => by simp at h
+  | _ :: _, _ :: _, Γ, .cons hA hAs, hΓ, 0, _, h => by
+      simp only [List.getElem?_cons_zero] at h
+      cases h
+      simpa using hA.closedN henv hΓ
+  | A :: As, _ :: _, Γ, .cons hA hAs, hΓ, i + 1, field, h => by
+      simp only [List.getElem?_cons_succ] at h
+      have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ
+      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using
+        VEnv.OnSortTel.closedAt henv hAs ⟨hΓ, hclosed⟩ h
+
+private theorem VEnv.OnTel.liftTelN_eq {env : VEnv} {U : Nat}
+    (henv : env.Ordered) :
+    ∀ {As Γ}, env.OnTel U Γ As → CtxClosed Γ → ∀ n,
+      VExpr.liftTelN n As Γ.length = As
+  | [], _, _, _, _ => rfl
+  | A :: As, Γ, ⟨hA, hAs⟩, hΓ, n => by
+      obtain ⟨_, hA⟩ := hA
+      have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ
+      simp only [VExpr.liftTelN, hclosed.liftN_eq (Nat.le_refl _)]
+      simpa using VEnv.OnTel.liftTelN_eq henv hAs ⟨hΓ, hclosed⟩ n
+
+private theorem VEnv.OnSortTel.liftTelN_eq {env : VEnv} {U : Nat}
+    (henv : env.Ordered) :
+    ∀ {As us Γ}, env.OnSortTel U Γ As us → CtxClosed Γ → ∀ n,
+      VExpr.liftTelN n As Γ.length = As
+  | [], [], _, .nil, _, _ => rfl
+  | A :: As, _ :: us, Γ, .cons hA hAs, hΓ, n => by
+      have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ
+      simp only [VExpr.liftTelN, hclosed.liftN_eq (Nat.le_refl _)]
+      simpa using VEnv.OnSortTel.liftTelN_eq henv hAs ⟨hΓ, hclosed⟩ n
+
+/-- The checked, generated description of a nonrecursive structure.
+
+`generation` supplies the exact family, constructor, recursor, and iota rule
+artifacts.  The shape fields restrict that general one-family artifact to the
+kernel class on which `.proj` is meaningful: no indices, exactly one
+constructor, and no recursive constructor arguments.  `fieldSorts` records
+the motive universe required by each projection; `WF` below ties every entry
+to the corresponding dependent constructor field type. -/
+structure VStructureView where
+  source : VInductDecl
+  generation : source.GenerationChecked
+  constructor : NormalizedCtor
+  constructor_eq : generation.block.ctorPairs = [constructor]
+  raw_indices_eq : generation.block.rawIndices = []
+  checked_indices_eq : generation.block.checked.indices = []
+  recursive_eq : constructor.view.recursive = []
+  fieldSorts : List VLevel
+  fieldSorts_length :
+    fieldSorts.length = (constructor.rawFields source.nparams).length
+
+namespace VStructureView
+
+abbrev name (view : VStructureView) : Name :=
+  view.generation.block.sourceType.name
+
+abbrev constructorName (view : VStructureView) : Name :=
+  view.constructor.raw.name
+
+def recursorName (view : VStructureView) : Name :=
+  .str view.name "rec"
+
+abbrev uvars (view : VStructureView) : Nat := view.source.uvars
+
+abbrev nparams (view : VStructureView) : Nat := view.source.nparams
+
+abbrev familyType (view : VStructureView) : VExpr :=
+  view.generation.block.sourceType.type
+
+def constructorParams (view : VStructureView) : List VExpr :=
+  VExpr.telN view.nparams view.constructor.raw.type
+
+def fields (view : VStructureView) : List VExpr :=
+  view.constructor.rawFields view.nparams
+
+/-- The instantiated structure type `S.{levels} params`. -/
+def structureType (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) : VExpr :=
+  VExpr.appN (.const view.name levels) params
+
+/-- Specialize declaration universes and constructor parameters, retaining
+the preceding field binders of each dependent field. -/
+def specializedFields (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) : List VExpr :=
+  view.fields.zipIdx.map fun (field, i) =>
+    VExpr.instRevAt (field.instL levels) params i
+
+private theorem specializedFieldsAux_liftN
+    (rawFields : List VExpr) (levels : List VLevel)
+    (params : List VExpr) (p start n k : Nat)
+    (hparams : params.length = p)
+    (hclosed : ∀ (j : Nat) (field : VExpr),
+      rawFields[j]? = some field →
+        field.ClosedN (p + start + j)) :
+    (rawFields.zipIdx start |>.map fun (field, i) =>
+      VExpr.instRevAt (field.instL levels)
+        (params.map fun param => param.liftN n k) i) =
+    VExpr.liftTelN n
+      (rawFields.zipIdx start |>.map fun (field, i) =>
+        VExpr.instRevAt (field.instL levels) params i)
+      (k + start) := by
+  induction rawFields generalizing start with
+  | nil => rfl
+  | cons field rawFields ih =>
+      have hfield : (field.instL levels).ClosedN (p + start + 0) :=
+        VExpr.ClosedN.instL (ls := levels) (hclosed 0 field (by rfl))
+      have hrawLift :
+          (field.instL levels).liftN n
+              (k + start + params.length) = field.instL levels :=
+        hfield.liftN_eq (by rw [hparams]; omega)
+      have hhead := VExpr.liftN_instRevAt
+        (field.instL levels) params start k n
+      rw [hrawLift] at hhead
+      have htail := ih (start := start + 1)
+        (fun j tailField htailField => by
+          have := hclosed (j + 1) tailField (by simpa using htailField)
+          simpa only [Nat.add_assoc, Nat.add_left_comm,
+            Nat.add_comm] using this)
+      simp only [List.zipIdx, List.map_cons, VExpr.liftTelN]
+      rw [← hhead]
+      exact congrArg
+        (List.cons (VExpr.liftN n
+          ((field.instL levels).instRevAt params start) (k + start)))
+        (by simpa only [Nat.add_assoc] using htail)
+
+private theorem specializedFieldsAux_instN
+    (rawFields : List VExpr) (levels : List VLevel)
+    (params : List VExpr) (p start k : Nat) (a : VExpr)
+    (hparams : params.length = p)
+    (hclosed : ∀ (j : Nat) (field : VExpr),
+      rawFields[j]? = some field →
+        field.ClosedN (p + start + j)) :
+    (rawFields.zipIdx start |>.map fun (field, i) =>
+      VExpr.instRevAt (field.instL levels)
+        (params.map fun param => param.inst a k) i) =
+    VExpr.instTelN a
+      (rawFields.zipIdx start |>.map fun (field, i) =>
+        VExpr.instRevAt (field.instL levels) params i)
+      (k + start) := by
+  induction rawFields generalizing start with
+  | nil => rfl
+  | cons field rawFields ih =>
+      have hfield : (field.instL levels).ClosedN (p + start + 0) :=
+        VExpr.ClosedN.instL (ls := levels) (hclosed 0 field (by rfl))
+      have hrawInst :
+          (field.instL levels).inst a
+              (k + start + params.length) = field.instL levels :=
+        hfield.instN_eq (by rw [hparams]; omega)
+      have hhead := VExpr.instN_instRevAt
+        (field.instL levels) params start k a
+      rw [hrawInst] at hhead
+      have htail := ih (start := start + 1)
+        (fun j tailField htailField => by
+          have := hclosed (j + 1) tailField (by simpa using htailField)
+          simpa only [Nat.add_assoc, Nat.add_left_comm,
+            Nat.add_comm] using this)
+      simp only [List.zipIdx, List.map_cons, VExpr.instTelN]
+      rw [← hhead]
+      exact congrArg
+        (List.cons (VExpr.inst
+          ((field.instL levels).instRevAt params start) a (k + start)))
+        (by simpa only [Nat.add_assoc] using htail)
+
+/-- Universe arguments supplied to the generated recursor for a projection
+whose result type inhabits `Sort fieldSort`. -/
+def projectionLevels (view : VStructureView)
+    (fieldSort : VLevel) (levels : List VLevel) : List VLevel :=
+  match view.generation.elimination with
+  | .large => fieldSort :: levels
+  | .small => levels
+
+/-- The two expressions generated for one field.  `typeFn` is the dependent
+field type as a function of the structure value; `projector` is a recursor
+program implementing the projection. -/
+structure ProjectionCode where
+  fieldSort : VLevel
+  typeFn : VExpr
+  minor : VExpr
+  projector : VExpr
+
+@[ext] theorem ProjectionCode.ext {left right : ProjectionCode}
+    (fieldSort : left.fieldSort = right.fieldSort)
+    (typeFn : left.typeFn = right.typeFn)
+    (minor : left.minor = right.minor)
+    (projector : left.projector = right.projector) : left = right := by
+  cases left
+  cases right
+  simp_all
+
+def ProjectionCode.liftN (code : ProjectionCode)
+    (n k : Nat) : ProjectionCode where
+  fieldSort := code.fieldSort
+  typeFn := code.typeFn.liftN n k
+  minor := code.minor.liftN n k
+  projector := code.projector.liftN n k
+
+def ProjectionCode.instN (code : ProjectionCode)
+    (a : VExpr) (k : Nat) : ProjectionCode where
+  fieldSort := code.fieldSort
+  typeFn := code.typeFn.inst a k
+  minor := code.minor.inst a k
+  projector := code.projector.inst a k
+
+def ProjectionCode.instL (code : ProjectionCode)
+    (ls : List VLevel) : ProjectionCode where
+  fieldSort := code.fieldSort.inst ls
+  typeFn := code.typeFn.instL ls
+  minor := code.minor.instL ls
+  projector := code.projector.instL ls
+
+/-- The constructor-headed major used by a projection minor after all fields
+have been introduced. -/
+def projectionConstructorApp (view : VStructureView)
+    (levels : List VLevel) (params fields : List VExpr) : VExpr :=
+  VExpr.appN (.const view.constructorName levels)
+    (params.map (VExpr.liftN fields.length) ++
+      VExpr.bvarRevRange 0 fields.length)
+
+/-- The one-constructor, nonrecursive minor premise expected by the generated
+recursor after parameters and a projection motive have been supplied. -/
+def projectionMinorType (view : VStructureView)
+    (levels : List VLevel) (params fields : List VExpr)
+    (typeFn : VExpr) : VExpr :=
+  VExpr.forallN fields
+    (.app (typeFn.liftN fields.length)
+      (view.projectionConstructorApp levels params fields))
+
+@[simp] theorem projectionLevels_instL (view : VStructureView)
+    (fieldSort : VLevel) (levels ls : List VLevel) :
+    (view.projectionLevels fieldSort levels).map (VLevel.inst ls) =
+      view.projectionLevels (fieldSort.inst ls)
+        (levels.map (VLevel.inst ls)) := by
+  unfold projectionLevels
+  split <;> rfl
+
+@[simp] theorem structureType_instL (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (ls : List VLevel) :
+    (view.structureType levels params).instL ls =
+      view.structureType (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) := by
+  simp [structureType, VExpr.instL_appN, VExpr.instL,
+    VLevel.inst_inst, Function.comp_def]
+
+@[simp] theorem structureType_liftN (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (n k : Nat) :
+    (view.structureType levels params).liftN n k =
+      view.structureType levels
+        (params.map fun param => param.liftN n k) := by
+  simp [structureType, VExpr.liftN_appN, VExpr.liftN]
+
+@[simp] theorem structureType_instN (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (a : VExpr) (k : Nat) :
+    (view.structureType levels params).inst a k =
+      view.structureType levels
+        (params.map fun param => param.inst a k) := by
+  simp [structureType, VExpr.instN_appN, VExpr.inst]
+
+@[simp] theorem specializedFields_instL (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (ls : List VLevel) :
+    (view.specializedFields levels params).map (VExpr.instL ls) =
+      view.specializedFields (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) := by
+  simp [specializedFields, VExpr.instL_instRevAt,
+    VExpr.instL_instL, VLevel.inst_inst, Function.comp_def]
+
+private def projectionCode (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType field : VExpr) (fieldSort : VLevel) (i : Nat)
+    (previous : List ProjectionCode) : ProjectionCode :=
+  let previousAtMajor := previous.map fun code =>
+    .app code.projector.lift (.bvar 0)
+  let motiveBody := VExpr.instRevAt
+    (field.liftN 1 i) previousAtMajor 0
+  let typeFn := .lam structType motiveBody
+  let minor := VExpr.lamN allFields
+    (.bvar (allFields.length - 1 - i))
+  let recursor := .const view.recursorName
+    (view.projectionLevels fieldSort levels)
+  let projector := .lam structType <| VExpr.appN recursor <|
+    params.map (VExpr.liftN 1) ++
+      [typeFn.lift, minor.lift, .bvar 0]
+  { fieldSort, typeFn, minor, projector }
+
+private theorem projectionCode_liftN (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType field : VExpr) (fieldSort : VLevel) (i : Nat)
+    (previous : List ProjectionCode) (n k : Nat)
+    (hprevious : previous.length = i)
+    (hi : i < allFields.length) :
+    (projectionCode view levels params allFields structType field
+      fieldSort i previous).liftN n k =
+    projectionCode view levels
+      (params.map fun param => param.liftN n k)
+      (VExpr.liftTelN n allFields k)
+      (structType.liftN n k) (field.liftN n (k + i)) fieldSort i
+      (previous.map fun code => code.liftN n k) := by
+  have hfieldLift :
+      (field.liftN 1 i).liftN n (k + 1 + i) =
+        (field.liftN n (k + i)).liftN 1 i :=
+    VExpr.liftN_liftAt_projection field n k i
+  have hpreviousLift :
+      (previous.map fun code =>
+        VExpr.app code.projector.lift (.bvar 0)).map
+          (fun (e : VExpr) => e.liftN n (k + 1)) =
+      (previous.map fun code => code.liftN n k).map fun code =>
+        VExpr.app code.projector.lift (.bvar 0) := by
+    simp [ProjectionCode.liftN, VExpr.liftN,
+      VExpr.liftN_lift_projection, List.map_map,
+      Function.comp_def]
+  have hmotive :
+      ((field.liftN 1 i).instRevAt
+          (previous.map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0).liftN n (k + 1) =
+      ((field.liftN n (k + i)).liftN 1 i).instRevAt
+          ((previous.map fun code => code.liftN n k).map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0 := by
+    rw [VExpr.liftN_instRevAt]
+    rw [List.length_map, hprevious, hfieldLift, hpreviousLift]
+  have hminorBody :
+      VExpr.liftN n (.bvar (allFields.length - 1 - i))
+          (k + allFields.length) =
+        .bvar (allFields.length - 1 - i) := by
+    simp only [VExpr.liftN]
+    rw [liftVar_lt]
+    omega
+  have hminorVar :
+      liftVar n (allFields.length - 1 - i)
+          (k + allFields.length) = allFields.length - 1 - i := by
+    rw [liftVar_lt]
+    omega
+  have hminorNestedVar :
+      liftVar n (liftVar 1 (allFields.length - 1 - i)
+          allFields.length) (k + 1 + allFields.length) =
+        liftVar 1 (allFields.length - 1 - i) allFields.length := by
+    have hinner : liftVar 1 (allFields.length - 1 - i)
+        allFields.length = allFields.length - 1 - i :=
+      liftVar_lt (by omega)
+    rw [hinner, liftVar_lt (by omega)]
+  have hmotiveLift :
+      (((field.liftN 1 i).instRevAt
+          (previous.map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0).liftN 1 1).liftN
+          n (k + 1 + 1) =
+      (((field.liftN n (k + i)).liftN 1 i).instRevAt
+          ((previous.map fun code => code.liftN n k).map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0).liftN 1 1 := by
+    rw [VExpr.liftN_liftAt_projection]
+    exact congrArg (fun e => e.liftN 1 1) hmotive
+  apply ProjectionCode.ext
+  · rfl
+  · simp [projectionCode, ProjectionCode.liftN, VExpr.liftN,
+      hmotive]
+  · simp [projectionCode, ProjectionCode.liftN,
+      VExpr.liftN_lamN_projection, VExpr.liftTelN_length,
+      hminorBody]
+  · simp [projectionCode, ProjectionCode.liftN, VExpr.liftN,
+      VExpr.liftN_appN, VExpr.liftN_lamN_projection,
+      VExpr.liftTelN_length, VExpr.liftN_lift_projection,
+      VExpr.liftTelN_lift_projection, List.map_append,
+      List.map_map, Function.comp_def, hmotive, hmotiveLift,
+      hminorNestedVar]
+
+private theorem projectionCode_instN (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType field : VExpr) (fieldSort : VLevel) (i : Nat)
+    (previous : List ProjectionCode) (a : VExpr) (k : Nat)
+    (hprevious : previous.length = i)
+    (hi : i < allFields.length) :
+    (projectionCode view levels params allFields structType field
+      fieldSort i previous).instN a k =
+    projectionCode view levels
+      (params.map fun param => param.inst a k)
+      (VExpr.instTelN a allFields k)
+      (structType.inst a k) (field.inst a (k + i)) fieldSort i
+      (previous.map fun code => code.instN a k) := by
+  have hfieldInst :
+      (field.liftN 1 i).inst a (k + 1 + i) =
+        (field.inst a (k + i)).liftN 1 i :=
+    VExpr.instN_liftAt_projection field a k i
+  have hpreviousInst :
+      (previous.map fun code =>
+        VExpr.app code.projector.lift (.bvar 0)).map
+          (fun (e : VExpr) => e.inst a (k + 1)) =
+      (previous.map fun code => code.instN a k).map fun code =>
+        VExpr.app code.projector.lift (.bvar 0) := by
+    simp [ProjectionCode.instN, VExpr.inst, VExpr.instVar,
+      ← VExpr.lift_instN_lo, List.map_map, Function.comp_def]
+  have hmotive :
+      ((field.liftN 1 i).instRevAt
+          (previous.map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0).inst a (k + 1) =
+      ((field.inst a (k + i)).liftN 1 i).instRevAt
+          ((previous.map fun code => code.instN a k).map fun code =>
+            VExpr.app code.projector.lift (.bvar 0)) 0 := by
+    rw [VExpr.instN_instRevAt]
+    rw [List.length_map, hprevious, hfieldInst, hpreviousInst]
+  have hminorVar :
+      VExpr.instVar (allFields.length - 1 - i) a
+          (k + allFields.length) =
+        .bvar (allFields.length - 1 - i) := by
+    simp [VExpr.instVar, show
+      allFields.length - 1 - i < k + allFields.length by omega]
+  apply ProjectionCode.ext
+  · rfl
+  · simp [projectionCode, ProjectionCode.instN, VExpr.inst, hmotive]
+  · simp [projectionCode, ProjectionCode.instN, VExpr.inst,
+      VExpr.instN_lamN_projection, VExpr.instTelN_length,
+      hminorVar]
+  · simp [projectionCode, ProjectionCode.instN, VExpr.inst,
+      VExpr.instN_appN, VExpr.instN_lamN_projection,
+      VExpr.instTelN_length, ← VExpr.lift_instN_lo,
+      VExpr.instTelN_lift_projection, List.map_append,
+      List.map_map, Function.comp_def, hmotive, hminorVar]
+
+private def projectionCodes.go (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr)
+    (allFields : List VExpr) (structType : VExpr) :
+    List VExpr → List VLevel → Nat → List ProjectionCode →
+      List ProjectionCode
+  | field :: fields, fieldSort :: fieldSorts, i, previous =>
+      let code := projectionCode view levels params allFields structType
+        field fieldSort i previous
+      code :: projectionCodes.go view levels params allFields structType
+        fields fieldSorts (i + 1) (previous ++ [code])
+  | _, _, _, _ => []
+
+private theorem projectionCodes.go_instN (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType : VExpr) (fields : List VExpr)
+    (fieldSorts : List VLevel) (i : Nat)
+    (previous : List ProjectionCode) (a : VExpr) (k : Nat)
+    (hprevious : previous.length = i)
+    (hfields : i + fields.length = allFields.length) :
+    (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous).map
+      (fun code => code.instN a k) =
+    projectionCodes.go view levels
+      (params.map fun param => param.inst a k)
+      (VExpr.instTelN a allFields k) (structType.inst a k)
+      (VExpr.instTelN a fields (k + i)) fieldSorts i
+      (previous.map fun code => code.instN a k) := by
+  induction fields generalizing fieldSorts i previous with
+  | nil =>
+      cases fieldSorts <;> simp [projectionCodes.go, VExpr.instTelN]
+  | cons field fields ih =>
+      cases fieldSorts with
+      | nil => simp [projectionCodes.go]
+      | cons fieldSort fieldSorts =>
+          have hi : i < allFields.length := by
+            simp only [List.length_cons] at hfields
+            omega
+          have hcode := projectionCode_instN view levels params allFields
+            structType field fieldSort i previous a k hprevious hi
+          simp only [projectionCodes.go, List.map_cons,
+            VExpr.instTelN]
+          rw [hcode]
+          congr 1
+          have hprevious' :
+              (previous ++ [projectionCode view levels params allFields
+                structType field fieldSort i previous]).length = i + 1 := by
+            simp [hprevious]
+          have hfields' : i + 1 + fields.length = allFields.length := by
+            simp only [List.length_cons] at hfields
+            omega
+          simpa only [List.map_append, List.map_singleton,
+            hcode, Nat.add_assoc] using
+              ih fieldSorts (i + 1)
+                (previous ++ [projectionCode view levels params allFields
+                  structType field fieldSort i previous])
+                hprevious' hfields'
+
+private theorem projectionCode_instL (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType field : VExpr) (fieldSort : VLevel) (i : Nat)
+    (previous : List ProjectionCode) (ls : List VLevel) :
+    (projectionCode view levels params allFields structType field
+      fieldSort i previous).instL ls =
+    projectionCode view
+      (levels.map (VLevel.inst ls))
+      (params.map (VExpr.instL ls))
+      (allFields.map (VExpr.instL ls))
+      (structType.instL ls) (field.instL ls) (fieldSort.inst ls) i
+      (previous.map fun code => code.instL ls) := by
+  simp [projectionCode, ProjectionCode.instL, VExpr.instL,
+    VExpr.instL_instRevAt, VExpr.instL_lamN_projection,
+    VExpr.instL_appN, VExpr.instL_liftN,
+    List.map_append, List.map_map, Function.comp_def]
+
+private theorem projectionCodes.go_instL (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType : VExpr) (fields : List VExpr)
+    (fieldSorts : List VLevel) (i : Nat)
+    (previous : List ProjectionCode) (ls : List VLevel) :
+    (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous).map
+      (fun code => code.instL ls) =
+    projectionCodes.go view
+      (levels.map (VLevel.inst ls))
+      (params.map (VExpr.instL ls))
+      (allFields.map (VExpr.instL ls))
+      (structType.instL ls)
+      (fields.map (VExpr.instL ls))
+      (fieldSorts.map (VLevel.inst ls)) i
+      (previous.map fun code => code.instL ls) := by
+  induction fields generalizing fieldSorts i previous with
+  | nil => simp [projectionCodes.go]
+  | cons field fields ih =>
+      cases fieldSorts with
+      | nil => simp [projectionCodes.go]
+      | cons fieldSort fieldSorts =>
+          simp only [projectionCodes.go, List.map_cons,
+            projectionCode_instL]
+          congr 1
+          simpa only [List.map_append, List.map_singleton,
+            projectionCode_instL] using
+            ih fieldSorts (i + 1)
+              (previous ++ [projectionCode view levels params allFields
+                structType field fieldSort i previous])
+
+private theorem projectionCodes.go_liftN (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType : VExpr) (fields : List VExpr)
+    (fieldSorts : List VLevel) (i : Nat)
+    (previous : List ProjectionCode) (n k : Nat)
+    (hprevious : previous.length = i)
+    (hfields : i + fields.length = allFields.length) :
+    (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous).map
+      (fun code => code.liftN n k) =
+    projectionCodes.go view levels
+      (params.map fun param => param.liftN n k)
+      (VExpr.liftTelN n allFields k) (structType.liftN n k)
+      (VExpr.liftTelN n fields (k + i)) fieldSorts i
+      (previous.map fun code => code.liftN n k) := by
+  induction fields generalizing fieldSorts i previous with
+  | nil =>
+      cases fieldSorts <;> simp [projectionCodes.go, VExpr.liftTelN]
+  | cons field fields ih =>
+      cases fieldSorts with
+      | nil => simp [projectionCodes.go]
+      | cons fieldSort fieldSorts =>
+          have hi : i < allFields.length := by
+            simp only [List.length_cons] at hfields
+            omega
+          have hcode := projectionCode_liftN view levels params allFields
+            structType field fieldSort i previous n k hprevious hi
+          simp only [projectionCodes.go, List.map_cons,
+            VExpr.liftTelN]
+          rw [hcode]
+          congr 1
+          have hprevious' :
+              (previous ++ [projectionCode view levels params allFields
+                structType field fieldSort i previous]).length = i + 1 := by
+            simp [hprevious]
+          have hfields' : i + 1 + fields.length = allFields.length := by
+            simp only [List.length_cons] at hfields
+            omega
+          simpa only [List.map_append, List.map_singleton,
+            hcode, Nat.add_assoc] using
+              ih fieldSorts (i + 1)
+                (previous ++ [projectionCode view levels params allFields
+                  structType field fieldSort i previous])
+                hprevious' hfields'
+
+/-- All field projections, in constructor-field order. -/
+def projectionCodes (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) : List ProjectionCode :=
+  let fields := view.specializedFields levels params
+  projectionCodes.go view levels params fields
+    (view.structureType levels params) fields
+      (view.fieldSorts.map (VLevel.inst levels)) 0 []
+
+private theorem projectionCodes.go_length (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType : VExpr) :
+    ∀ (fields : List VExpr) (fieldSorts : List VLevel)
+      (i : Nat) (previous : List ProjectionCode),
+      fields.length = fieldSorts.length →
+      (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous).length = fields.length
+  | [], [], _, _, _ => rfl
+  | [], _ :: _, _, _, h => by simp at h
+  | _ :: _, [], _, _, h => by simp at h
+  | field :: fields, fieldSort :: fieldSorts, i, previous, h => by
+      simp only [List.length_cons] at h ⊢
+      simp only [projectionCodes.go, List.length_cons]
+      exact congrArg Nat.succ <|
+        projectionCodes.go_length view levels params allFields structType
+          fields fieldSorts (i + 1)
+          (previous ++ [projectionCode view levels params allFields
+            structType field fieldSort i previous]) (Nat.succ.inj h)
+
+@[simp] theorem projectionCodes_length (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) :
+    (view.projectionCodes levels params).length =
+      (view.specializedFields levels params).length := by
+  apply projectionCodes.go_length
+  simp [VStructureView.specializedFields, VStructureView.fields,
+    view.fieldSorts_length]
+
+/-- Semantic arguments substituted while walking to a later dependent
+projection field. -/
+def projectionArgs (view : VStructureView) (levels : List VLevel)
+    (params : List VExpr) (count : Nat) (major : VExpr) : List VExpr :=
+  (view.projectionCodes levels params).take count |>.map fun code =>
+    .app code.projector major
+
+/-- Rebuild a structure value from all of its canonical generated
+projections.  This is syntax only: `ProgramsWF.projectionArgsSpine` below
+supplies the rule-independent typing evidence, while any equality between
+this term and `major` remains an explicit definitional-equality capability. -/
+def etaRebuild (view : VStructureView) (levels : List VLevel)
+    (params : List VExpr) (major : VExpr) : VExpr :=
+  VExpr.appN (.const view.constructorName levels)
+    (params ++ view.projectionArgs levels params
+      (view.specializedFields levels params).length major)
+
+@[simp] theorem projectionArgs_length (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (count : Nat)
+    (major : VExpr) (hcount : count ≤
+      (view.projectionCodes levels params).length) :
+    (view.projectionArgs levels params count major).length = count := by
+  simp only [projectionArgs, List.length_map, List.length_take]
+  exact Nat.min_eq_left hcount
+
+theorem projectionArgs_succ (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (count : Nat)
+    (major : VExpr) {code : ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[count]? = some code) :
+    view.projectionArgs levels params (count + 1) major =
+      view.projectionArgs levels params count major ++
+        [.app code.projector major] := by
+  simp only [projectionArgs, List.take_add_one, hcode, Option.toList_some,
+    List.map_append, List.map_singleton]
+
+private theorem projectionCodes.go_get?_typeFn (view : VStructureView)
+    (levels : List VLevel) (params allFields : List VExpr)
+    (structType : VExpr) :
+    ∀ {fields : List VExpr} {fieldSorts : List VLevel}
+      {i : Nat} {previous : List ProjectionCode} {j : Nat}
+      {code : ProjectionCode},
+      (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous)[j]? = some code →
+      ∃ field,
+        fields[j]? = some field ∧
+        code.typeFn = .lam structType
+          ((field.liftN 1 (i + j)).instRevAt
+            ((previous ++
+              (projectionCodes.go view levels params allFields structType
+                fields fieldSorts i previous).take j).map fun prior =>
+                .app prior.projector.lift (.bvar 0)) 0) := by
+  intro fields
+  induction fields with
+  | nil =>
+      intro fieldSorts i previous j code h
+      cases fieldSorts <;> simp [projectionCodes.go] at h
+  | cons field fields ih =>
+      intro fieldSorts i previous j code h
+      cases fieldSorts with
+      | nil => simp [projectionCodes.go] at h
+      | cons fieldSort fieldSorts =>
+          let head := projectionCode view levels params allFields structType
+            field fieldSort i previous
+          cases j with
+          | zero =>
+              change some head = some code at h
+              injection h with hcode
+              subst code
+              refine ⟨field, rfl, ?_⟩
+              simp [head, projectionCode]
+          | succ j =>
+              simp only [projectionCodes.go, List.getElem?_cons_succ] at h
+              obtain ⟨tailField, htailField, htypeFn⟩ :=
+                ih (fieldSorts := fieldSorts) (i := i + 1)
+                  (previous := previous ++ [head]) h
+              refine ⟨tailField, by simpa using htailField, ?_⟩
+              have hpref :
+                  previous ++
+                    (projectionCodes.go view levels params allFields structType
+                      (field :: fields) (fieldSort :: fieldSorts) i previous).take
+                        (j + 1) =
+                    (previous ++ [head]) ++
+                      (projectionCodes.go view levels params allFields structType
+                        fields fieldSorts (i + 1)
+                          (previous ++ [head])).take j := by
+                simp [head, projectionCodes.go, List.take,
+                  List.append_assoc]
+              rw [hpref]
+              simpa only [Nat.add_assoc, Nat.add_comm,
+                Nat.add_left_comm] using htypeFn
+
+/-- The generated type function at field `idx` is the corresponding
+specialized constructor field with all earlier generated projectors
+substituted at the major premise. -/
+theorem projectionCodes_get?_typeFn (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) {idx : Nat}
+    {code : ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[idx]? = some code) :
+    ∃ field,
+      (view.specializedFields levels params)[idx]? = some field ∧
+      code.typeFn = .lam (view.structureType levels params)
+        ((field.liftN 1 idx).instRevAt
+          ((view.projectionCodes levels params).take idx |>.map fun prior =>
+            .app prior.projector.lift (.bvar 0)) 0) := by
+  unfold projectionCodes at hcode ⊢
+  simpa using projectionCodes.go_get?_typeFn view levels params
+    (view.specializedFields levels params)
+    (view.structureType levels params) hcode
+
+private theorem projectionCodes.go_get?_program_shape
+    (view : VStructureView) (levels : List VLevel)
+    (params allFields : List VExpr) (structType : VExpr) :
+    ∀ {fields : List VExpr} {fieldSorts : List VLevel}
+      {i : Nat} {previous : List ProjectionCode} {j : Nat}
+      {code : ProjectionCode},
+      (projectionCodes.go view levels params allFields structType
+        fields fieldSorts i previous)[j]? = some code →
+      ∃ fieldSort,
+        fieldSorts[j]? = some fieldSort ∧
+          code.fieldSort = fieldSort ∧
+          code.minor = VExpr.lamN allFields
+            (.bvar (allFields.length - 1 - (i + j))) ∧
+          code.projector = .lam structType
+            (VExpr.appN
+              (.const view.recursorName
+                (view.projectionLevels code.fieldSort levels))
+              (params.map (VExpr.liftN 1) ++
+                [code.typeFn.lift, code.minor.lift, .bvar 0])) := by
+  intro fields
+  induction fields with
+  | nil =>
+      intro fieldSorts i previous j code h
+      cases fieldSorts <;> simp [projectionCodes.go] at h
+  | cons field fields ih =>
+      intro fieldSorts i previous j code h
+      cases fieldSorts with
+      | nil => simp [projectionCodes.go] at h
+      | cons fieldSort fieldSorts =>
+          let head := projectionCode view levels params allFields structType
+            field fieldSort i previous
+          cases j with
+          | zero =>
+              change some head = some code at h
+              injection h with hcode
+              subst code
+              simp [head, projectionCode]
+          | succ j =>
+              simp only [projectionCodes.go, List.getElem?_cons_succ] at h
+              have hout := ih (fieldSorts := fieldSorts) (i := i + 1)
+                (previous := previous ++ [head]) h
+              simpa only [List.getElem?_cons_succ, Nat.add_assoc, Nat.add_comm,
+                Nat.add_left_comm] using hout
+
+/-- A selected projection code retains the exact selecting minor and
+recursor program emitted by `projectionCodes`. -/
+theorem projectionCodes_get?_program_shape (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) {idx : Nat}
+    {code : ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[idx]? = some code) :
+    ∃ fieldSort,
+      (view.fieldSorts.map (VLevel.inst levels))[idx]? = some fieldSort ∧
+        code.fieldSort = fieldSort ∧
+        code.minor = VExpr.lamN (view.specializedFields levels params)
+          (.bvar ((view.specializedFields levels params).length - 1 - idx)) ∧
+        code.projector = .lam (view.structureType levels params)
+          (VExpr.appN
+            (.const view.recursorName
+              (view.projectionLevels code.fieldSort levels))
+            (params.map (VExpr.liftN 1) ++
+              [code.typeFn.lift, code.minor.lift, .bvar 0])) := by
+  unfold projectionCodes at hcode
+  simpa using projectionCodes.go_get?_program_shape view levels params
+    (view.specializedFields levels params)
+    (view.structureType levels params) hcode
+
+/-- Applying a generated projection's type function to its major premise
+substitutes that major into every earlier generated projector. -/
+theorem projectionCodes_get?_typeFn_beta (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) {idx : Nat}
+    {code : ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[idx]? = some code)
+    (major : VExpr) :
+    ∃ field typeBody,
+      (view.specializedFields levels params)[idx]? = some field ∧
+      code.typeFn = .lam (view.structureType levels params) typeBody ∧
+      typeBody.inst major =
+        field.instRevAt
+          ((view.projectionCodes levels params).take idx |>.map fun prior =>
+            .app prior.projector major) 0 := by
+  obtain ⟨field, hfield, htypeFn⟩ :=
+    view.projectionCodes_get?_typeFn levels params hcode
+  let codes := view.projectionCodes levels params
+  have hidx : idx < codes.length :=
+    (List.getElem?_eq_some_iff.1 hcode).1
+  have htake : (codes.take idx).length = idx := by
+    simp [List.length_take, Nat.min_eq_left (Nat.le_of_lt hidx)]
+  have htake' :
+      ((view.projectionCodes levels params).take idx).length = idx := by
+    simpa [codes] using htake
+  refine ⟨field, _, hfield, htypeFn, ?_⟩
+  rw [VExpr.instN_instRevAt]
+  rw [List.length_map, htake']
+  simp only [Nat.zero_add, VExpr.inst_liftN1]
+  congr 1
+  induction (view.projectionCodes levels params).take idx with
+  | nil => rfl
+  | cons prior previous ih =>
+      simp only [List.map_cons]
+      rw [ih]
+      simp only [VExpr.inst, VExpr.inst_lift, VExpr.instVar_zero]
+
+@[simp] theorem projectionCodes_instL (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr) (ls : List VLevel) :
+    (view.projectionCodes levels params).map
+        (fun code => code.instL ls) =
+      view.projectionCodes (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) := by
+  simp [projectionCodes, projectionCodes.go_instL,
+    VLevel.inst_inst, List.map_map, Function.comp_def]
+
+/-- The dependent result type of projection `idx`, applied to `major`. -/
+def projectionType? (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr)
+    (idx : Nat) (major : VExpr) : Option VExpr := do
+  let code ← (view.projectionCodes levels params)[idx]?
+  return .app code.typeFn major
+
+/-- The recursor encoding of projection `idx`, applied to `major`. -/
+def project? (view : VStructureView)
+    (levels : List VLevel) (params : List VExpr)
+    (idx : Nat) (major : VExpr) : Option VExpr := do
+  let code ← (view.projectionCodes levels params)[idx]?
+  return .app code.projector major
+
+/-- A proof-carrying boundary for the programs generated by
+`projectionCodes`.  Generation fixes the program syntax, while this
+certificate records the remaining semantic fact needed by consumers: every
+selected projector is well typed at every well-formed instantiation.
+
+This is intentionally separate from `VStructureView.WF`.  The latter is the
+certificate produced by ordinary inductive generation; accepting primitive
+projection syntax is a later capability boundary and must not silently add a
+structure-eta rule to Theory's definitional equality. -/
+def ProgramsWF (view : VStructureView) (env : VEnv) : Prop :=
+  ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+      {params : List VExpr} {idx : Nat} {code : ProjectionCode},
+    OnCtx Γ (env.IsType U) →
+    (∀ level ∈ levels, level.WF U) →
+    levels.length = view.uvars →
+    params.length = view.nparams →
+    (∃ resultLevel, env.SpineWF U Γ (view.familyType.instL levels)
+      params (.sort resultLevel)) →
+    (view.projectionCodes levels params)[idx]? = some code →
+    env.HasType U Γ code.projector
+      (.forallE (view.structureType levels params)
+        (.app code.typeFn.lift (.bvar 0)))
+
+/-- A certified projector is typed by the exact constructor-telescope domain
+exposed after substituting all earlier projections. -/
+theorem ProgramsWF.projector_hasType_field
+    {view : VStructureView} {env : VEnv}
+    (self : view.ProgramsWF env) (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+    {params : List VExpr} {idx : Nat} {code : ProjectionCode}
+    (hΓ : OnCtx Γ (env.IsType U))
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    (hcode : (view.projectionCodes levels params)[idx]? = some code)
+    {major : VExpr}
+    (hmajor : env.HasType U Γ major (view.structureType levels params)) :
+    ∃ field typeBody,
+      (view.specializedFields levels params)[idx]? = some field ∧
+      code.typeFn = .lam (view.structureType levels params) typeBody ∧
+      env.HasType U Γ (.app code.projector major)
+        (field.instRevAt (view.projectionArgs levels params idx major) 0) := by
+  obtain ⟨field, typeBody, hfield, htypeFn, htypeBody⟩ :=
+    view.projectionCodes_get?_typeFn_beta levels params hcode major
+  have hprojector := self hΓ hlevels hlevelsLength hparamsLength
+    hparamsSpine hcode
+  have happ : env.HasType U Γ (.app code.projector major)
+      (.app code.typeFn major) := by
+    simpa only [VExpr.inst, VExpr.inst_lift, VExpr.instVar_zero] using
+      hprojector.app hmajor
+  rw [htypeFn] at happ
+  obtain ⟨sortLevel, hredexType⟩ := happ.isType henv hΓ
+  obtain ⟨A, B, hlam, harg⟩ := hredexType.app_inv henv hΓ
+  obtain ⟨⟨_, hstructType⟩, _, hbodyType⟩ :=
+    hlam.lam_inv henv hΓ
+  have hfunTypeEq := hlam.uniqU henv hΓ
+    (hstructType.lam hbodyType)
+  obtain ⟨⟨_, hdomainEq⟩, _⟩ :=
+    hfunTypeEq.forallE_inv henv hΓ
+  have harg' := harg.defeqU_r henv hΓ ⟨_, hdomainEq⟩
+  have hbeta : env.IsDefEqU U Γ
+      (.app (.lam (view.structureType levels params) typeBody) major)
+      (typeBody.inst major) :=
+    ⟨_, VEnv.IsDefEq.beta hbodyType harg'⟩
+  have hout := happ.defeqU_r henv hΓ hbeta
+  rw [htypeBody] at hout
+  refine ⟨field, typeBody, hfield, htypeFn, ?_⟩
+  simpa [projectionArgs] using hout
+
+private theorem ProgramsWF.projectionArgsSpineAux
+    {view : VStructureView} {env : VEnv}
+    (self : view.ProgramsWF env) (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+    {params : List VExpr}
+    (hΓ : OnCtx Γ (env.IsType U))
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    {major : VExpr}
+    (hmajor : env.HasType U Γ major (view.structureType levels params))
+    (tailResult : VExpr) :
+    ∀ {count : Nat},
+      count ≤ (view.specializedFields levels params).length →
+      ∃ cursor,
+        VExpr.consumeForalls?
+            (VExpr.forallN (view.specializedFields levels params) tailResult)
+            (view.projectionArgs levels params count major) = some cursor ∧
+          env.SpineWF U Γ
+            (VExpr.forallN (view.specializedFields levels params) tailResult)
+            (view.projectionArgs levels params count major) cursor := by
+  intro count hcount
+  induction count with
+  | zero =>
+      exact ⟨_, rfl, .nil⟩
+  | succ count ih =>
+      have hcountLt : count <
+          (view.specializedFields levels params).length := by omega
+      have hcodeIdx : count <
+          (view.projectionCodes levels params).length := by
+        simpa using hcountLt
+      let code := (view.projectionCodes levels params)[count]
+      have hcode :
+          (view.projectionCodes levels params)[count]? = some code :=
+        List.getElem?_eq_getElem hcodeIdx
+      have hargsLength :
+          (view.projectionArgs levels params count major).length = count :=
+        view.projectionArgs_length levels params count major
+          (Nat.le_of_lt hcodeIdx)
+      obtain ⟨cursor, hconsume, hspine⟩ :=
+        ih (Nat.le_of_lt hcountLt)
+      obtain ⟨field, semanticBody, hfield, hconsumeDomain⟩ :=
+        VExpr.consumeForalls?_forallN_domain
+          (view.specializedFields levels params) tailResult
+          (view.projectionArgs levels params count major)
+          (by simpa [hargsLength] using hcountLt)
+      have hcursorShape : cursor =
+          .forallE
+            (field.instRevAt
+              (view.projectionArgs levels params count major) 0)
+            semanticBody :=
+        Option.some.inj (hconsume.symm.trans hconsumeDomain)
+      subst cursor
+      obtain ⟨field', _, hfield', _, hprojectorField⟩ :=
+        self.projector_hasType_field henv hΓ hlevels hlevelsLength
+          hparamsLength hparamsSpine hcode hmajor
+      have hfieldEq : field' = field :=
+        Option.some.inj
+          (hfield'.symm.trans (by simpa [hargsLength] using hfield))
+      subst field'
+      refine ⟨semanticBody.inst (.app code.projector major), ?_, ?_⟩
+      · rw [view.projectionArgs_succ levels params count major hcode]
+        rw [VExpr.consumeForalls?_append, hconsumeDomain]
+        rfl
+      · rw [view.projectionArgs_succ levels params count major hcode]
+        exact hspine.snoc hprojectorField
+
+/-- All canonical generated projections of a well-typed major form a single
+well-typed dependent constructor-field spine.  This theorem deliberately
+stops at typing: it does not assert structure eta. -/
+theorem ProgramsWF.projectionArgsSpine
+    {view : VStructureView} {env : VEnv}
+    (self : view.ProgramsWF env) (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+    {params : List VExpr}
+    (hΓ : OnCtx Γ (env.IsType U))
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    {major : VExpr}
+    (hmajor : env.HasType U Γ major (view.structureType levels params))
+    (tailResult : VExpr) :
+    env.SpineWF U Γ
+      (VExpr.forallN (view.specializedFields levels params) tailResult)
+      (view.projectionArgs levels params
+        (view.specializedFields levels params).length major)
+      (VExpr.instRev tailResult
+        (view.projectionArgs levels params
+          (view.specializedFields levels params).length major)) := by
+  obtain ⟨_, _, hspine⟩ := self.projectionArgsSpineAux henv hΓ hlevels
+    hlevelsLength hparamsLength hparamsSpine hmajor tailResult
+    (Nat.le_refl _)
+  apply hspine.retarget
+  · exact view.projectionArgs_length levels params
+      (view.specializedFields levels params).length major (by simp)
+
+/-- Applying the complete canonical projection spine to a constructor prefix
+is well typed.  The constructor-prefix premise is kept explicit so this
+lemma remains independent of any proposed structure-eta equality rule. -/
+theorem ProgramsWF.etaRebuild_hasType_of_constructorPrefix
+    {view : VStructureView} {env : VEnv}
+    (self : view.ProgramsWF env) (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+    {params : List VExpr}
+    (hΓ : OnCtx Γ (env.IsType U))
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    {major : VExpr}
+    (hmajor : env.HasType U Γ major (view.structureType levels params))
+    (hconstructorPrefix : env.HasType U Γ
+      (VExpr.appN (.const view.constructorName levels) params)
+      (VExpr.forallN (view.specializedFields levels params)
+        ((view.structureType levels params).liftN
+          (view.specializedFields levels params).length))) :
+    env.HasType U Γ (view.etaRebuild levels params major)
+      (view.structureType levels params) := by
+  have hfields := self.projectionArgsSpine henv hΓ hlevels hlevelsLength
+    hparamsLength hparamsSpine hmajor
+    ((view.structureType levels params).liftN
+      (view.specializedFields levels params).length)
+  have hrebuild := hfields.hasType_appN hconstructorPrefix
+  let args := view.projectionArgs levels params
+    (view.specializedFields levels params).length major
+  have hargsLength :
+      args.length = (view.specializedFields levels params).length :=
+    view.projectionArgs_length levels params
+      (view.specializedFields levels params).length major (by simp)
+  have hlift :
+      (view.structureType levels params).liftN
+          (view.specializedFields levels params).length =
+        (view.structureType levels params).liftN args.length :=
+    congrArg (view.structureType levels params).liftN hargsLength.symm
+  have hresult :
+      VExpr.instRev
+        ((view.structureType levels params).liftN
+          (view.specializedFields levels params).length)
+        args =
+        view.structureType levels params := by
+    calc
+      _ = VExpr.instRev
+          ((view.structureType levels params).liftN args.length) args :=
+        congrArg (VExpr.instRev · args) hlift
+      _ = view.structureType levels params :=
+        VExpr.instRev_liftN_len args _
+  rw [hresult] at hrebuild
+  simpa [etaRebuild, VExpr.appN_append] using hrebuild
+
+/-- Exact registration of the checked structure artifact in a Theory
+environment.  These are concrete lookups and generated iota rules, not an
+oracle supplied by a projection consumer. -/
+structure Registered (view : VStructureView) (env : VEnv) : Prop where
+  family : env.constants view.name =
+    some view.generation.block.sourceType.toVConstant
+  constructor : env.constants view.constructorName =
+    some view.constructor.raw.toVConstant
+  recursor : env.constants view.recursorName =
+    some view.generation.recursor
+  rules : ∀ rule ∈ view.generation.generatedRules, env.defeqs rule
+
+/-- The semantic fragment of `GenerationEnv` that remains monotone under an
+arbitrary environment extension.  Ordering is supplied by the structural-law
+caller; exact constant/rule registration is carried separately by
+`Registered`. -/
+structure GenerationSemantics (view : VStructureView) (env : VEnv) : Prop where
+  checked : view.generation.block.checked.WF env
+  familyTelescope :
+    env.TelDefEq view.uvars []
+      (view.generation.block.rawParams ++
+        view.generation.block.rawIndices)
+      (view.generation.block.checked.params ++
+        view.generation.block.checked.indices)
+  familyResult :
+    env.IsDefEq view.uvars
+      (view.generation.block.rawParams ++
+        view.generation.block.rawIndices).reverse
+      view.generation.block.rawResult
+      (.sort view.generation.block.checked.resultLevel)
+      (.sort (.succ view.generation.block.checked.resultLevel))
+  constructor : view.constructor.WF view.generation.block env
+
+/-- Semantic well-formedness of one structure view in its registered
+environment.  The retained sort list is checked against the exact raw
+dependent field telescope. -/
+structure WF (view : VStructureView) (env : VEnv) : Prop
+    extends VStructureView.Registered view env where
+  generationSemantics : VStructureView.GenerationSemantics view env
+  parameters : env.OnTel view.uvars []
+    view.generation.block.checked.params
+  parameters_length :
+    view.generation.block.checked.params.length = view.nparams
+  fieldTelescope : env.OnSortTel view.uvars
+    view.generation.block.checked.params.reverse
+      view.fields view.fieldSorts
+  smallFields : view.generation.elimination = .small →
+    ∀ level ∈ view.fieldSorts, level = .zero
+
+theorem WF.rule_mem (self : VStructureView.WF view env) {df : VDefEq}
+    (h : df ∈ VInductDecl.GenerationChecked.generatedRules view.generation) :
+    VEnv.defeqs env df :=
+  self.rules df h
+
+/-- The semantic capability required by structure-eta consumers.
+
+`VStructureView.WF` and `ProgramsWF` account for the registered structure
+artifact and the typing of its generated projectors.  This property records
+only the additional equality that those rule-independent certificates do not
+derive: rebuilding every canonical projection is definitionally equal to the
+original major premise.  Keeping it as an explicit environment capability
+prevents checker verification from silently extending `VEnv.IsDefEq`. -/
+def _root_.Lean4Lean.VEnv.HasStructureEta (env : VEnv) : Prop :=
+  ∀ (view : VStructureView), view.WF env → view.ProgramsWF env →
+    ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+      {params : List VExpr} {major : VExpr},
+      OnCtx Γ (env.IsType U) →
+      (∀ level ∈ levels, level.WF U) →
+      levels.length = view.uvars →
+      params.length = view.nparams →
+      (∃ resultLevel, env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel)) →
+      env.HasType U Γ major (view.structureType levels params) →
+      env.IsDefEq U Γ (view.etaRebuild levels params major) major
+        (view.structureType levels params)
+
+theorem Registered.mono {env env' : VEnv} (henv : env ≤ env')
+    (self : VStructureView.Registered view env) :
+    VStructureView.Registered view env' where
+  family := henv.1 self.family
+  constructor := henv.1 self.constructor
+  recursor := henv.1 self.recursor
+  rules := fun rule hrule => henv.2 (self.rules rule hrule)
+
+theorem GenerationSemantics.mono {env env' : VEnv} (henv : env ≤ env')
+    (self : VStructureView.GenerationSemantics view env) :
+    VStructureView.GenerationSemantics view env' where
+  checked := self.checked.mono henv
+  familyTelescope := self.familyTelescope.mono henv
+  familyResult := self.familyResult.mono henv
+  constructor := self.constructor.mono henv
+
+/-- Recover the monotone semantic fragment of a generated structure from the
+ordinary generation certificate and the exact successful transaction trace. -/
+theorem GenerationSemantics.ofGenerationTrace {pre env : VEnv}
+    (hgen : view.generation.WF pre)
+    (trace : VEnv.AddInductGenerationTrace pre env view.generation) :
+    VStructureView.GenerationSemantics view env := by
+  have htypeFinal : trace.typeEnv ≤ env := by
+    have hctors :=
+      (ctorFold_spec view.generation.block.sourceType.ctors
+        trace.addCtors).1
+    have hrec := VEnv.addConst_le trace.addRec
+    have hrules : trace.recEnv ≤ env := by
+      simpa only [trace.addRules] using
+        (rulesFold_spec view.generation.generatedRules trace.recEnv).1
+    exact hctors.trans (hrec.trans hrules)
+  have hpreFinal := trace.le
+  refine {
+    checked := hgen.blockWF.2.mono hpreFinal
+    familyTelescope := hgen.familyTel.mono hpreFinal
+    familyResult := hgen.familyResult.mono hpreFinal
+    constructor := ?_ }
+  have hconstructor :
+      view.constructor ∈ view.generation.block.ctorPairs := by
+    simp [view.constructor_eq]
+  exact (hgen.ctors trace.typeEnv trace.addType view.constructor
+    hconstructor).mono htypeFinal
+
+theorem WF.mono {env env' : VEnv} (henv : env ≤ env')
+    (self : VStructureView.WF view env) : VStructureView.WF view env' where
+  toRegistered := self.toRegistered.mono henv
+  generationSemantics := self.generationSemantics.mono henv
+  parameters := self.parameters.monoProjection henv
+  parameters_length := self.parameters_length
+  fieldTelescope := self.fieldTelescope.mono henv
+  smallFields := self.smallFields
+
+/-- Reassemble the standard generated-artifact invariant when an ordered
+environment is available. -/
+theorem WF.toGenerationEnv (self : VStructureView.WF view env)
+    (henv : env.Ordered) :
+    VInductDecl.GenerationEnv view.generation env where
+  ord := henv
+  checked := self.generationSemantics.checked
+  familyTel := self.generationSemantics.familyTelescope
+  familyResult := self.generationSemantics.familyResult
+  ctorWF := by
+    intro ctor hctor
+    rw [view.constructor_eq] at hctor
+    simp only [List.mem_singleton] at hctor
+    subst ctor
+    exact self.generationSemantics.constructor
+  familyConst := self.family
+  ctorConst := by
+    intro ctor hctor
+    rw [view.constructor_eq] at hctor
+    simp only [List.mem_singleton] at hctor
+    subst ctor
+    exact self.constructor
+
+theorem WF.field_closed (self : VStructureView.WF view env)
+    (henv : env.Ordered) {i : Nat} {field : VExpr}
+    (hfield : view.fields[i]? = some field) :
+    field.ClosedN (view.nparams + i) := by
+  have hparamsCtx : OnCtx
+      view.generation.block.checked.params.reverse
+      (env.IsType view.uvars) :=
+    by simpa using VEnv.OnTel.toOnCtx self.parameters (by trivial)
+  have hclosed := VEnv.OnSortTel.closedAt henv self.fieldTelescope
+    (VEnv.CtxWF.closed henv hparamsCtx) hfield
+  simpa [self.parameters_length] using hclosed
+
+theorem WF.specializedFields_liftN
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr)
+    (hparams : params.length = view.nparams) (n k : Nat) :
+    view.specializedFields levels
+        (params.map fun param => param.liftN n k) =
+      VExpr.liftTelN n (view.specializedFields levels params) k := by
+  simpa [specializedFields] using
+    specializedFieldsAux_liftN view.fields levels params view.nparams
+      0 n k hparams
+      (fun j field hfield => by
+        simpa using self.field_closed henv hfield)
+
+theorem WF.specializedFields_instN
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr)
+    (hparams : params.length = view.nparams) (a : VExpr) (k : Nat) :
+    view.specializedFields levels
+        (params.map fun param => param.inst a k) =
+      VExpr.instTelN a (view.specializedFields levels params) k := by
+  simpa [specializedFields] using
+    specializedFieldsAux_instN view.fields levels params view.nparams
+      0 k a hparams
+      (fun j field hfield => by
+        simpa using self.field_closed henv hfield)
+
+private theorem projectionLevels_length (view : VStructureView)
+    (fieldSort : VLevel) (levels : List VLevel)
+    (hlevels : levels.length = view.uvars) :
+    (view.projectionLevels fieldSort levels).length =
+      view.generation.recUvars := by
+  unfold projectionLevels
+  cases h : view.generation.elimination <;>
+    simp [VInductDecl.GenerationChecked.recUvars,
+      VInductDecl.ElimMode.recUvars, h, hlevels]
+
+private theorem projectionLevels_wf (view : VStructureView)
+    {U : Nat} (fieldSort : VLevel) (levels : List VLevel)
+    (hfieldSort : fieldSort.WF U)
+    (hlevels : ∀ level ∈ levels, level.WF U) :
+    ∀ level ∈ view.projectionLevels fieldSort levels, level.WF U := by
+  unfold projectionLevels
+  cases view.generation.elimination <;> simp_all
+
+private theorem sourceLevels_projectionLevels (view : VStructureView)
+    (fieldSort : VLevel) (levels : List VLevel)
+    (hlevels : levels.length = view.uvars) :
+    view.generation.sourceLevels.map
+        (VLevel.inst (view.projectionLevels fieldSort levels)) = levels := by
+  unfold VInductDecl.GenerationChecked.sourceLevels
+  unfold VInductDecl.ElimMode.sourceLevels projectionLevels
+  cases h : view.generation.elimination
+  ·
+    change (VLevel.params' view.uvars 1).map
+      (VLevel.inst (fieldSort :: levels)) = levels
+    have hshift :
+        (VLevel.params' view.uvars 1).map
+            (VLevel.inst (fieldSort :: levels)) =
+          (VLevel.params view.uvars).map (VLevel.inst levels) := by
+      simp [VLevel.params', VLevel.params, List.map_map,
+        Function.comp_def, VLevel.inst,
+        List.getD_eq_getElem?_getD]
+    rw [hshift]
+    exact VLevel.inst_map_id hlevels
+  ·
+    change (VLevel.params' view.uvars 0).map
+      (VLevel.inst levels) = levels
+    have hzero : VLevel.params' view.uvars 0 =
+        VLevel.params view.uvars := by
+      simp [VLevel.params', VLevel.params]
+    rw [hzero]
+    exact VLevel.inst_map_id hlevels
+
+private theorem motiveLevel_projectionLevels (view : VStructureView)
+    (fieldSort : VLevel) (levels : List VLevel) :
+    view.generation.motiveLevel.inst
+        (view.projectionLevels fieldSort levels) =
+      match view.generation.elimination with
+      | .large => fieldSort
+      | .small => .zero := by
+  unfold VInductDecl.GenerationChecked.motiveLevel
+  unfold VInductDecl.ElimMode.motiveLevel projectionLevels
+  cases view.generation.elimination <;> rfl
+
+private theorem WF.motiveLevel_projectionLevels
+    (self : VStructureView.WF view env)
+    (fieldSort : VLevel) (hfieldSort : fieldSort ∈ view.fieldSorts)
+    (levels : List VLevel) :
+    view.generation.motiveLevel.inst
+        (view.projectionLevels (fieldSort.inst levels) levels) =
+      fieldSort.inst levels := by
+  rw [VStructureView.motiveLevel_projectionLevels]
+  cases hmode : view.generation.elimination with
+  | large => rfl
+  | small =>
+      rw [self.smallFields hmode fieldSort hfieldSort]
+      rfl
+
+@[simp] theorem WF.projectionCodes_liftN
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr)
+    (hparams : params.length = view.nparams) (n k : Nat) :
+    (view.projectionCodes levels params).map
+        (fun code => code.liftN n k) =
+      view.projectionCodes levels
+        (params.map fun param => param.liftN n k) := by
+  unfold projectionCodes
+  rw [self.specializedFields_liftN henv levels params hparams n k]
+  rw [← structureType_liftN]
+  apply projectionCodes.go_liftN
+  · rfl
+  · simp [VExpr.liftTelN_length]
+
+@[simp] theorem WF.projectionCodes_instN
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr)
+    (hparams : params.length = view.nparams) (a : VExpr) (k : Nat) :
+    (view.projectionCodes levels params).map
+        (fun code => code.instN a k) =
+      view.projectionCodes levels
+        (params.map fun param => param.inst a k) := by
+  unfold projectionCodes
+  rw [self.specializedFields_instN henv levels params hparams a k]
+  rw [← structureType_instN]
+  apply projectionCodes.go_instN
+  · rfl
+  · simp [VExpr.instTelN_length]
+
+/-- The exact lower-layer structure-eta descriptor generated by a checked
+structure view.  Its projector syntax is the deterministic projector program
+list already certified by the view; the proof fields are only the three
+syntactic naturality laws required by Theory transport. -/
+def WF.toStructEta (self : VStructureView.WF view env)
+    (henv : env.Ordered) : VStructEta where
+  uvars := view.uvars
+  nparams := view.nparams
+  nfields := view.fields.length
+  familyName := view.name
+  familyType := view.familyType
+  constructorName := view.constructorName
+  projectors := fun levels params =>
+    (view.projectionCodes levels params).map (·.projector)
+  projectors_length := by
+    intro levels params _ _
+    simp [VStructureView.specializedFields, VStructureView.fields]
+  projectors_liftN := by
+    intro levels params n k hparams
+    have h := self.projectionCodes_liftN henv levels params hparams n k
+    simpa [List.map_map, ProjectionCode.liftN, Function.comp_def] using
+      congrArg (List.map (·.projector)) h
+  projectors_instN := by
+    intro levels params a k hparams
+    have h := self.projectionCodes_instN henv levels params hparams a k
+    simpa [List.map_map, ProjectionCode.instN, Function.comp_def] using
+      congrArg (List.map (·.projector)) h
+  projectors_instL := by
+    intro levels params ls
+    have h := projectionCodes_instL view levels params ls
+    simpa [List.map_map, ProjectionCode.instL, Function.comp_def] using
+      congrArg (List.map (·.projector)) h
+
+@[simp] theorem WF.toStructEta_structureType
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr) :
+    (self.toStructEta henv).structureType levels params =
+      view.structureType levels params := rfl
+
+@[simp] theorem WF.toStructEta_rebuild
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr) :
+    (self.toStructEta henv).rebuild levels params major =
+      view.etaRebuild levels params major := by
+  simp only [VStructEta.rebuild, VStructEta.projectionArgs, WF.toStructEta,
+    VStructureView.etaRebuild, VStructureView.projectionArgs]
+  rw [← view.projectionCodes_length levels params, List.take_length]
+  simp [List.map_map, Function.comp_def]
+
+end VStructureView
+
+namespace VEnv
+
+/-- Registered checked views supply the former semantic structure-eta
+capability.  The registry contributes only membership; subject reduction is
+recovered from the ordered environment, and the equality itself is the
+primitive `IsDefEq.structEta` step. -/
+theorem hasStructureEta_of_registry (henv : env.Ordered)
+    (registered : ∀ (view : VStructureView)
+      (hview : view.WF env) (_ : view.ProgramsWF env),
+      env.structEtas (hview.toStructEta henv)) :
+    env.HasStructureEta := by
+  intro view hview programs U Γ levels params major hΓ hlevels
+    hlevelsLength hparamsLength hparamsSpine hmajor
+  let rule := hview.toStructEta henv
+  have hregistered : env.structEtas rule := registered view hview programs
+  have hruleWF : rule.WF env := henv.structEtaWF hregistered
+  obtain ⟨resultLevel, hparamsSpine⟩ := hparamsSpine
+  have hrebuild := hruleWF.rebuild_hasType VEnv.LE.rfl hΓ hlevels
+    hlevelsLength hparamsLength ⟨resultLevel, hparamsSpine⟩ hmajor
+  have heta := IsDefEq.structEta hregistered hlevels hlevelsLength
+    hparamsLength hparamsSpine hmajor hrebuild
+  simpa [rule] using heta
+
+private theorem SpineWF.monoProjection {env env' : VEnv}
+    (henv : env ≤ env') :
+    ∀ {A es B}, env.SpineWF U Γ A es B → env'.SpineWF U Γ A es B
+  | _, _, _, h => h.mono henv
+
+/-- The view-facing direction of `TelDefEq.spine_sort`: arguments checked
+against the retained raw telescope also consume its definitionally equal
+view telescope. -/
+theorem TelDefEq.spine_sort_view
+    {env : VEnv} {U : Nat} (henv : env.Ordered) :
+    ∀ {Γ As As' es l}, env.TelDefEq U Γ As As' →
+      env.SpineWF U Γ (VExpr.forallN As (.sort l)) es (.sort l) →
+      es.length = As.length →
+      env.SpineWF U Γ (VExpr.forallN As' (.sort l)) es (.sort l)
+  | _, [], [], [], _, _, hspine, _ => by simpa using hspine
+  | _, [], [], _ :: _, _, _, _, hlen => by simp at hlen
+  | Γ, A :: As, A' :: As', e :: es, l, ⟨⟨_, hA⟩, hT⟩,
+      .cons he hrest, hlen => by
+    have heView : env.HasType U Γ e A' := hA.defeq he
+    have hTinst := TelDefEq.instN henv he (.zero) hT
+    have hrest' : env.SpineWF U Γ
+        (VExpr.forallN (VExpr.instTelN e As 0) (.sort l))
+        es (.sort l) := by
+      simpa [VExpr.instN_forallN, VExpr.inst] using hrest
+    have hlen' : es.length = As.length := by simpa using hlen
+    have hlenInst :
+        es.length = (VExpr.instTelN e As 0).length := by
+      rw [VExpr.instTelN_length]
+      exact hlen'
+    have hout := TelDefEq.spine_sort_view henv
+      hTinst hrest' hlenInst
+    refine .cons heView ?_
+    simpa [VExpr.instN_forallN, VExpr.inst] using hout
+
+/-- Parameters accepted by the structure family also consume the stored raw
+constructor parameter prefix.  This is the semantic bridge used by the
+kernel projection checker before it traverses the constructor fields. -/
+theorem _root_.Lean4Lean.VStructureView.WF.constructorParamsSpine
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    {U : Nat} {Γ : List VExpr} (levels : List VLevel)
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (params : List VExpr) (hparamsLength : params.length = view.nparams)
+    (paramsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    (target : VExpr) :
+    env.SpineWF U Γ
+      (VExpr.forallN
+        (view.constructorParams.map (VExpr.instL levels))
+        target) params (VExpr.instRev target params) := by
+  let S := self.toGenerationEnv henv
+  obtain ⟨resultLevel, hspine⟩ := paramsSpine
+  have hrawLength :
+      view.generation.block.rawParams.length = view.nparams :=
+    view.generation.shape.1
+  have hspineShape : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (view.generation.block.rawResult.instL levels))
+      params (.sort resultLevel) := by
+    simpa [VStructureView.familyType,
+      VInductDecl.NormalizedChecked.rawType_eq,
+      view.raw_indices_eq, VExpr.instL_forallN,
+      VExpr.forallN] using hspine
+  have hparamsRaw : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (.sort .zero)) params (.sort .zero) := by
+    have hout := hspineShape.retarget
+      (by simpa [hrawLength] using hparamsLength) (.sort .zero)
+    rw [VExpr.instRev_closedN params (by trivial)] at hout
+    exact hout
+  have hfamilyDefEq := S.rawParams_defeq.instL hlevels
+  have hrawLift : VExpr.liftTelN Γ.length
+      (view.generation.block.rawParams.map (VExpr.instL levels)) 0 =
+      view.generation.block.rawParams.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hfamilyDefEq.raw_onTel (by trivial) Γ.length
+  have hcheckedLift : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      (hfamilyDefEq.view_onTel henv) (by trivial) Γ.length
+  have hfamilyDefEqΓ := hfamilyDefEq.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hrawLift, hcheckedLift] at hfamilyDefEqΓ
+  simp only [List.append_nil] at hfamilyDefEqΓ
+  have hparamsChecked : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.checked.params.map (VExpr.instL levels))
+        (.sort .zero)) params (.sort .zero) :=
+    TelDefEq.spine_sort_view henv hfamilyDefEqΓ hparamsRaw
+      (by simpa [hrawLength] using hparamsLength)
+  have hconstructorMem :
+      view.constructor ∈ view.generation.block.ctorPairs := by
+    simp [view.constructor_eq]
+  have hconstructorShape :=
+    view.generation.shape.2.2.2.2.2 view.constructor hconstructorMem
+  have hconstructorDefEq₀ :=
+    ((S.ctorWF view.constructor hconstructorMem).declaredTel.take
+      view.nparams).instL hlevels
+  have hconstructorDefEq : env.TelDefEq U []
+      (view.constructorParams.map (VExpr.instL levels))
+      (view.generation.block.checked.params.map (VExpr.instL levels)) := by
+    simpa [VStructureView.constructorParams,
+      VInductDecl.NormalizedCtor.declaredBinders,
+      VInductDecl.NormalizedCtor.viewBinders,
+      hconstructorShape.2.2.1, self.parameters_length] using
+        hconstructorDefEq₀
+  have hconstructorRawLift : VExpr.liftTelN Γ.length
+      (view.constructorParams.map (VExpr.instL levels)) 0 =
+      view.constructorParams.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hconstructorDefEq.raw_onTel (by trivial) Γ.length
+  have hconstructorCheckedLift : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map (VExpr.instL levels) :=
+    hcheckedLift
+  have hconstructorDefEqΓ := hconstructorDefEq.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hconstructorRawLift, hconstructorCheckedLift] at hconstructorDefEqΓ
+  simp only [List.append_nil] at hconstructorDefEqΓ
+  have hout := TelDefEq.spine_sort henv hconstructorDefEqΓ hparamsChecked
+    (by simpa [VStructureView.constructorParams] using
+      hparamsLength.trans hconstructorShape.2.2.1.symm)
+  exact hout.retarget
+    (by simpa [VStructureView.constructorParams] using
+      hparamsLength.trans hconstructorShape.2.2.1.symm) target
+
+/-- Recover the structure-family parameter spine from the corresponding
+constructor-parameter prefix.  This is the converse consumer bridge needed
+when a checker recognizes a fully applied constructor before it knows the
+family application carried by its result type. -/
+theorem _root_.Lean4Lean.VStructureView.WF.familyParamsSpine_of_constructor
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    {U : Nat} {Γ : List VExpr} (levels : List VLevel)
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (params : List VExpr) (hparamsLength : params.length = view.nparams)
+    {target cursor : VExpr}
+    (constructorSpine : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.constructorParams.map (VExpr.instL levels)) target)
+      params cursor)
+    (resultLevel : VLevel)
+    (hresult : view.generation.block.rawResult = .sort resultLevel) :
+    env.SpineWF U Γ (view.familyType.instL levels) params
+      (.sort (resultLevel.inst levels)) := by
+  let S := self.toGenerationEnv henv
+  have hrawLength :
+      view.generation.block.rawParams.length = view.nparams :=
+    view.generation.shape.1
+  have hconstructorMem :
+      view.constructor ∈ view.generation.block.ctorPairs := by
+    simp [view.constructor_eq]
+  have hconstructorShape :=
+    view.generation.shape.2.2.2.2.2 view.constructor hconstructorMem
+  have hconstructorLength : params.length =
+      (view.constructorParams.map (VExpr.instL levels)).length := by
+    simpa [VStructureView.constructorParams] using
+      hparamsLength.trans hconstructorShape.2.2.1.symm
+  have hparamsConstructor : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.constructorParams.map (VExpr.instL levels)) (.sort .zero))
+      params (.sort .zero) := by
+    have hout := constructorSpine.retarget hconstructorLength (.sort .zero)
+    rw [VExpr.instRev_closedN params (by trivial)] at hout
+    exact hout
+  have hfamilyDefEq := S.rawParams_defeq.instL hlevels
+  have hrawLift : VExpr.liftTelN Γ.length
+      (view.generation.block.rawParams.map (VExpr.instL levels)) 0 =
+      view.generation.block.rawParams.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hfamilyDefEq.raw_onTel (by trivial) Γ.length
+  have hcheckedLift : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      (hfamilyDefEq.view_onTel henv) (by trivial) Γ.length
+  have hfamilyDefEqΓ := hfamilyDefEq.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hrawLift, hcheckedLift] at hfamilyDefEqΓ
+  simp only [List.append_nil] at hfamilyDefEqΓ
+  have hconstructorDefEq₀ :=
+    ((S.ctorWF view.constructor hconstructorMem).declaredTel.take
+      view.nparams).instL hlevels
+  have hconstructorDefEq : env.TelDefEq U []
+      (view.constructorParams.map (VExpr.instL levels))
+      (view.generation.block.checked.params.map (VExpr.instL levels)) := by
+    simpa [VStructureView.constructorParams,
+      VInductDecl.NormalizedCtor.declaredBinders,
+      VInductDecl.NormalizedCtor.viewBinders,
+      hconstructorShape.2.2.1, self.parameters_length] using
+        hconstructorDefEq₀
+  have hconstructorRawLift : VExpr.liftTelN Γ.length
+      (view.constructorParams.map (VExpr.instL levels)) 0 =
+      view.constructorParams.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hconstructorDefEq.raw_onTel (by trivial) Γ.length
+  have hconstructorDefEqΓ := hconstructorDefEq.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hconstructorRawLift, hcheckedLift] at hconstructorDefEqΓ
+  simp only [List.append_nil] at hconstructorDefEqΓ
+  have hparamsChecked : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.checked.params.map (VExpr.instL levels))
+        (.sort .zero)) params (.sort .zero) :=
+    VEnv.TelDefEq.spine_sort_view henv hconstructorDefEqΓ
+      hparamsConstructor hconstructorLength
+  have hrawParamsLength : params.length =
+      (view.generation.block.rawParams.map (VExpr.instL levels)).length := by
+    simpa [hrawLength] using hparamsLength
+  have hparamsRaw : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (.sort .zero)) params (.sort .zero) :=
+    VEnv.TelDefEq.spine_sort henv hfamilyDefEqΓ hparamsChecked
+      hrawParamsLength
+  have hout := hparamsRaw.retarget hrawParamsLength
+    (.sort (resultLevel.inst levels))
+  rw [VExpr.instRev_closedN params (by trivial)] at hout
+  simpa [VStructureView.familyType,
+    VInductDecl.NormalizedChecked.rawType_eq,
+    view.raw_indices_eq, hresult, VExpr.instL_forallN,
+    VExpr.forallN, VExpr.instL] using hout
+
+theorem _root_.Lean4Lean.VStructureView.WF.specializedFields_onSortTel
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    {U : Nat} {Γ : List VExpr} (levels : List VLevel)
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (params : List VExpr) (hparamsLength : params.length = view.nparams)
+    (paramsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel)) :
+    env.OnSortTel U Γ (view.specializedFields levels params)
+      (view.fieldSorts.map (VLevel.inst levels)) := by
+  let S := self.toGenerationEnv henv
+  obtain ⟨resultLevel, hspine⟩ := paramsSpine
+  have hrawLength :
+      view.generation.block.rawParams.length = view.nparams :=
+    view.generation.shape.1
+  have hspineShape : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (view.generation.block.rawResult.instL levels))
+      params (.sort resultLevel) := by
+    simpa [VStructureView.familyType,
+      VInductDecl.NormalizedChecked.rawType_eq,
+      view.raw_indices_eq, VExpr.instL_forallN,
+      VExpr.forallN] using hspine
+  have hparamsRaw : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (.sort resultLevel)) params (.sort resultLevel) := by
+    have hout := hspineShape.retarget
+      (by simpa [hrawLength] using hparamsLength)
+      (.sort resultLevel)
+    rw [VExpr.instRev_closedN params (by trivial)] at hout
+    exact hout
+  have hrawChecked := S.rawParams_defeq.instL hlevels
+  have hrawLift := VEnv.OnTel.liftTelN_eq henv
+    hrawChecked.raw_onTel (by trivial) Γ.length
+  have hcheckedLift := VEnv.OnTel.liftTelN_eq henv
+    (hrawChecked.view_onTel henv) (by trivial) Γ.length
+  have hrawLift' : VExpr.liftTelN Γ.length
+      (view.generation.block.rawParams.map (VExpr.instL levels)) 0 =
+      view.generation.block.rawParams.map (VExpr.instL levels) := by
+    simpa using hrawLift
+  have hcheckedLift' : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map (VExpr.instL levels) := by
+    simpa using hcheckedLift
+  have hrawCheckedΓ := hrawChecked.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hrawLift', hcheckedLift'] at hrawCheckedΓ
+  simp only [List.append_nil] at hrawCheckedΓ
+  have hparamsChecked : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.checked.params.map
+          (VExpr.instL levels)) (.sort resultLevel))
+      params (.sort resultLevel) := by
+    exact TelDefEq.spine_sort_view henv hrawCheckedΓ hparamsRaw
+      (by simpa [hrawLength] using hparamsLength)
+  have hfields := self.fieldTelescope.instL hlevels
+  have hcheckedParams := self.parameters.instL hlevels
+  have Wparams := Ctx.LiftN.consTel
+    (view.generation.block.checked.params.map (VExpr.instL levels))
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hcheckedLift'] at Wparams
+  have hcheckedCtx : OnCtx
+      (view.generation.block.checked.params.reverse.map
+        (VExpr.instL levels)) (env.IsType U) := by
+    simpa [List.map_reverse] using
+      VEnv.OnTel.toOnCtx hcheckedParams (by trivial)
+  have hfieldLift := VEnv.OnSortTel.liftTelN_eq henv hfields
+    (VEnv.CtxWF.closed henv hcheckedCtx) Γ.length
+  have hfieldsΓ := VEnv.OnSortTel.weakN henv
+    (by simpa [List.map_reverse] using Wparams) hfields
+  simp only [List.length_reverse, List.length_map] at hfieldLift
+  rw [hfieldLift] at hfieldsΓ
+  have hspecialized := VEnv.OnSortTel.instRevParams henv
+    hparamsChecked (by simpa [self.parameters_length] using hparamsLength)
+    (by simpa [List.map_reverse] using hfieldsΓ)
+  rw [VExpr.instRevAt_map_instL_zipIdx] at hspecialized
+  simpa [VStructureView.specializedFields] using hspecialized
+
+private theorem _root_.Lean4Lean.VStructureView.WF.generationParamsSpine
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    {U : Nat} {Γ : List VExpr} (levels : List VLevel)
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (params : List VExpr) (hparamsLength : params.length = view.nparams)
+    (paramsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    (fieldSort : VLevel) :
+    env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.paramsTel.map
+          (VExpr.instL
+            (view.projectionLevels fieldSort levels)))
+        (.sort fieldSort)) params (.sort fieldSort) := by
+  let S := self.toGenerationEnv henv
+  obtain ⟨resultLevel, hspine⟩ := paramsSpine
+  have hrawLength :
+      view.generation.block.rawParams.length = view.nparams :=
+    view.generation.shape.1
+  have hspineShape : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (view.generation.block.rawResult.instL levels))
+      params (.sort resultLevel) := by
+    simpa [VStructureView.familyType,
+      VInductDecl.NormalizedChecked.rawType_eq,
+      view.raw_indices_eq, VExpr.instL_forallN,
+      VExpr.forallN] using hspine
+  have hparamsRaw : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.rawParams.map (VExpr.instL levels))
+        (.sort fieldSort)) params (.sort fieldSort) := by
+    have hout := hspineShape.retarget
+      (by simpa [hrawLength] using hparamsLength) (.sort fieldSort)
+    rw [VExpr.instRev_closedN params (by trivial)] at hout
+    exact hout
+  have hrawChecked := S.rawParams_defeq.instL hlevels
+  have hrawLift : VExpr.liftTelN Γ.length
+      (view.generation.block.rawParams.map (VExpr.instL levels)) 0 =
+      view.generation.block.rawParams.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hrawChecked.raw_onTel (by trivial) Γ.length
+  have hcheckedLift : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      (hrawChecked.view_onTel henv) (by trivial) Γ.length
+  have hrawCheckedΓ := hrawChecked.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hrawLift, hcheckedLift] at hrawCheckedΓ
+  simp only [List.append_nil] at hrawCheckedΓ
+  have hparamsChecked : env.SpineWF U Γ
+      (VExpr.forallN
+        (view.generation.block.checked.params.map
+          (VExpr.instL levels)) (.sort fieldSort))
+      params (.sort fieldSort) :=
+    TelDefEq.spine_sort_view henv hrawCheckedΓ hparamsRaw
+      (by simpa [hrawLength] using hparamsLength)
+  have hgenerationChecked := S.generationParams_defeq.instL hlevels
+  have hgenerationLift : VExpr.liftTelN Γ.length
+      (view.generation.block.generationParams.map
+        (VExpr.instL levels)) 0 =
+      view.generation.block.generationParams.map
+        (VExpr.instL levels) := by
+    simpa using VEnv.OnTel.liftTelN_eq henv
+      hgenerationChecked.raw_onTel (by trivial) Γ.length
+  have hcheckedLift₂ : VExpr.liftTelN Γ.length
+      (view.generation.block.checked.params.map
+        (VExpr.instL levels)) 0 =
+      view.generation.block.checked.params.map
+        (VExpr.instL levels) := hcheckedLift
+  have hgenerationCheckedΓ := hgenerationChecked.weakN henv
+    (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ)
+  rw [hgenerationLift, hcheckedLift₂] at hgenerationCheckedΓ
+  simp only [List.append_nil] at hgenerationCheckedΓ
+  have hparamsGeneration := TelDefEq.spine_sort henv
+    hgenerationCheckedΓ hparamsChecked
+    (by simpa [S.generationParams_length] using hparamsLength)
+  have hsource := VStructureView.sourceLevels_projectionLevels
+    view fieldSort levels
+    hlevelsLength
+  have hparamsTel :
+      view.generation.paramsTel.map
+          (VExpr.instL (view.projectionLevels fieldSort levels)) =
+        view.generation.block.generationParams.map
+          (VExpr.instL levels) := by
+    simp [VInductDecl.GenerationChecked.paramsTel,
+      List.map_map, Function.comp_def, VExpr.instL_instL, hsource]
+  rw [hparamsTel]
+  exact hparamsGeneration
+
+theorem _root_.Lean4Lean.VStructureView.WF.recursorProjection_hasType
+    (self : VStructureView.WF view env) (henv : env.Ordered)
+    {U : Nat} {Γ : List VExpr} (levels : List VLevel)
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    (params : List VExpr) (hparamsLength : params.length = view.nparams)
+    (paramsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    (fieldSort : VLevel)
+    (hfieldSort : fieldSort.WF U)
+    (hmotiveLevel :
+      view.generation.motiveLevel.inst
+          (view.projectionLevels fieldSort levels) = fieldSort)
+    (structIsType : env.IsType U Γ
+      (view.structureType levels params))
+    {typeFn minor major : VExpr}
+    (typeFnType : env.HasType U Γ typeFn
+      (.forallE (view.structureType levels params) (.sort fieldSort)))
+    (minorType : env.HasType U Γ minor
+      (view.projectionMinorType levels params
+        (view.specializedFields levels params) typeFn))
+    (majorType : env.HasType U Γ major
+      (view.structureType levels params)) :
+    env.HasType U Γ
+      (VExpr.appN (.const view.recursorName
+        (view.projectionLevels fieldSort levels))
+        (params ++ [typeFn, minor, major]))
+      (.app typeFn major) := by
+  let gen := view.generation
+  let S := self.toGenerationEnv henv
+  let pLevels := view.projectionLevels fieldSort levels
+  let k := gen.block.ctorPairs.length
+  let ni := gen.idxTel.length
+  let recRest : VExpr :=
+    VExpr.forallN gen.minorTypes <|
+      VExpr.forallN (VExpr.liftTelN (k + 1) gen.idxTel 0) <|
+        .forallE
+          (VExpr.appN (.const gen.block.sourceType.name gen.sourceLevels)
+            (VExpr.bvarRevRange (ni + k + 1) view.nparams ++
+              VExpr.bvarRevRange 0 ni))
+          (.app
+            (VExpr.appN (.bvar (ni + k + 1))
+              (VExpr.bvarRevRange 1 ni))
+            (.bvar 0))
+  let recTail : VExpr := .forallE gen.motiveType recRest
+  have hrec : env.HasType U Γ
+      (.const view.recursorName pLevels)
+      ((VExpr.forallN gen.paramsTel recTail).instL pLevels) := by
+    have hout := VEnv.HasType.const (Γ := Γ) self.recursor
+      (VStructureView.projectionLevels_wf view fieldSort levels
+        hfieldSort hlevels)
+      (VStructureView.projectionLevels_length view fieldSort levels
+        hlevelsLength)
+    simpa [gen, pLevels, recTail, recRest, k, ni,
+      VStructureView.recursorName,
+      VInductDecl.GenerationChecked.recursor,
+      VInductDecl.GenerationChecked.recType] using hout
+  have hparams := self.generationParamsSpine henv levels hlevels
+    hlevelsLength params hparamsLength paramsSpine fieldSort
+  have hparamsTelLength : params.length =
+      (gen.paramsTel.map (VExpr.instL pLevels)).length := by
+    simp [gen, VInductDecl.GenerationChecked.paramsTel,
+      S.generationParams_length, hparamsLength]
+  have hparamsFull := hparams.retarget hparamsTelLength
+    (recTail.instL pLevels)
+  have hparamsFull' : env.SpineWF U Γ
+      ((VExpr.forallN gen.paramsTel recTail).instL pLevels)
+      params (VExpr.instRev (recTail.instL pLevels) params) := by
+    simpa [VExpr.instL_forallN] using hparamsFull
+  have hmotiveShape :
+      VExpr.instRev (recTail.instL pLevels) params =
+        .forallE
+          (.forallE (view.structureType levels params) (.sort fieldSort))
+          (VExpr.instRevAt (recRest.instL pLevels) params 1) := by
+    change VExpr.instRev
+      (.forallE (gen.motiveType.instL pLevels)
+        (recRest.instL pLevels)) params = _
+    have hconst : VExpr.instRev
+        (.const view.generation.block.sourceType.name levels) params =
+        .const view.generation.block.sourceType.name levels :=
+      VExpr.instRev_closedN params (by trivial)
+    have hrange :
+        (VExpr.bvarRevRange 0 view.source.nparams).map
+            (VExpr.instRev · params) = params := by
+      have hparamsLength' : params.length = view.source.nparams :=
+        hparamsLength
+      rw [← hparamsLength']
+      exact VExpr.map_instRev_bvarRevRange params
+    have hrangeL :
+        (VExpr.bvarRevRange 0 view.source.nparams).map
+            (fun x => (x.instL pLevels).instRev params) = params := by
+      calc
+        _ = ((VExpr.bvarRevRange 0 view.source.nparams).map
+              (VExpr.instL pLevels)).map (VExpr.instRev · params) := by
+            rw [List.map_map]
+            rfl
+        _ = params := by
+          rw [VExpr.bvarRevRange_map_instL]
+          exact hrange
+    have hsort :
+        (VExpr.sort fieldSort).instRevAt params 1 =
+          .sort fieldSort :=
+      VExpr.instRevAt_closedN params (by trivial)
+    rw [VExpr.instRev_forallE_projection]
+    congr 1
+    simp [gen, pLevels,
+      VInductDecl.GenerationChecked.motiveType,
+      VInductDecl.GenerationChecked.idxTel,
+      view.raw_indices_eq, VExpr.forallN, VExpr.bvarRevRange,
+      VExpr.instL, VExpr.instL_appN,
+      VExpr.instRev_forallE_projection,
+      VExpr.instRev_appN, Function.comp_def,
+      hconst, hrangeL, hsort, hmotiveLevel,
+      VStructureView.structureType,
+      VStructureView.sourceLevels_projectionLevels view fieldSort levels
+        hlevelsLength]
+  rw [hmotiveShape] at hparamsFull'
+  have hwithMotive := hparamsFull'.snoc typeFnType
+  have hconstructorMem :
+      view.constructor ∈ view.generation.block.ctorPairs := by
+    simp [view.constructor_eq]
+  have hresultIndices : view.constructor.view.resultIndices = [] := by
+    apply List.length_eq_zero_iff.1
+    rw [S.viewResultIndices_length hconstructorMem]
+    simp [view.checked_indices_eq]
+  have hminorShape :
+      ((VExpr.instRevAt (recRest.instL pLevels) params 1).inst typeFn) =
+        .forallE (view.projectionMinorType levels params
+            (view.specializedFields levels params) typeFn)
+          (.forallE (view.structureType levels params).lift
+            (.app (typeFn.liftN 2) (.bvar 0))) := by
+    simp [gen, pLevels, recRest, k, ni,
+      VInductDecl.GenerationChecked.minorTypes,
+      VInductDecl.GenerationChecked.minorTypesAux,
+      VInductDecl.GenerationChecked.minorType,
+      VInductDecl.GenerationChecked.idxTel,
+      VInductDecl.NormalizedCtor.fieldsR,
+      VInductDecl.NormalizedCtor.recArgsR,
+      VInductDecl.NormalizedCtor.resultIndicesR,
+      VInductDecl.ihsFromRecArgs,
+      VStructureView.projectionMinorType,
+      VStructureView.projectionConstructorApp,
+      view.constructor_eq, view.raw_indices_eq,
+      hresultIndices, view.recursive_eq,
+      VExpr.instL_forallN, VExpr.instL_appN,
+      VExpr.liftTelN_instL,
+      VExpr.instL_instL, VExpr.instN_forallN,
+      VExpr.instTelN,
+      VExpr.instRevAt_forallN_projection,
+      VExpr.instRevAt_forallE_projection,
+      VExpr.instN_appN, VExpr.instRev,
+      VExpr.instRev_appN, List.map_append,
+      VExpr.bvarRevRange, List.map_append,
+      List.map_map, Function.comp_def,
+      VStructureView.sourceLevels_projectionLevels view fieldSort levels
+        hlevelsLength, hparamsLength]
+    change VExpr.forallE _ _ = VExpr.forallE _ _
+    congr 1
+    · have hfieldTel :=
+        VExpr.instTelN_instRevAt_lift_projection
+          ((view.constructor.rawFields view.source.nparams).map
+            (VExpr.instL levels)) params typeFn 0
+      rw [VExpr.instRevAt_map_instL_zipIdx] at hfieldTel
+      have hfieldTel' :
+          VExpr.instTelN typeFn
+              ((VExpr.liftTelN 1
+                  ((view.constructor.rawFields view.source.nparams).map
+                    (VExpr.instL levels)) 0).zipIdx 1 |>.map
+                fun x => x.1.instRevAt params x.2) 0 =
+            view.specializedFields levels params := by
+        simpa [VStructureView.specializedFields,
+          VStructureView.fields] using hfieldTel
+      rw [hfieldTel']
+      congr 1
+      have hsourceLevels :=
+        VStructureView.sourceLevels_projectionLevels view fieldSort levels
+          hlevelsLength
+      change
+        (VLevel.params' view.source.uvars
+            view.generation.elimination.offset).map
+              (VLevel.inst pLevels) = levels at hsourceLevels
+      have hliftedLength :
+          (VExpr.liftTelN 1
+              ((view.constructor.rawFields view.source.nparams).map
+                (VExpr.instL levels)) 0).length =
+            (view.constructor.rawFields view.source.nparams).length := by
+        rw [VExpr.liftTelN_length]
+        simp
+      have hspecializedLength :
+          (view.specializedFields levels params).length =
+            (view.constructor.rawFields view.source.nparams).length := by
+        simp [VStructureView.specializedFields,
+          VStructureView.fields]
+      simp only [VExpr.forallN, VExpr.instL,
+        VExpr.bvarRevRange_map_instL,
+        hliftedLength, hspecializedLength, hparamsLength]
+      rw [hsourceLevels]
+      have hbody :=
+        VExpr.projectionMinorBody_shape view.constructorName levels
+          params (view.constructor.rawFields view.source.nparams).length
+          typeFn
+      rw [hparamsLength] at hbody
+      simpa only [Nat.add_comm] using hbody
+    · have hsourceLevels :=
+        VStructureView.sourceLevels_projectionLevels view fieldSort levels
+          hlevelsLength
+      change
+        (VLevel.params' view.source.uvars
+            view.generation.elimination.offset).map
+              (VLevel.inst pLevels) = levels at hsourceLevels
+      simp only [VExpr.forallN, VExpr.liftTelN, List.zipIdx_nil,
+        List.map_nil, VExpr.instTelN, Nat.add_zero,
+        VExpr.instL, VExpr.instL_appN,
+        VExpr.bvarRevRange_map_instL, VExpr.instL]
+      rw [hsourceLevels]
+      simpa [gen, hparamsLength, VStructureView.structureType] using
+        (VExpr.projectionMajorTail_shape view.name levels params typeFn)
+  rw [hminorShape] at hwithMotive
+  have hwithMinor := hwithMotive.snoc minorType
+  have hwithMajor : env.SpineWF U Γ
+      ((VExpr.forallN gen.paramsTel recTail).instL pLevels)
+      (params ++ [typeFn, minor, major]) (.app typeFn major) := by
+    have majorType' : env.HasType U Γ major
+        ((view.structureType levels params).lift.inst minor) := by
+      rw [VExpr.inst_lift]
+      exact majorType
+    have hout := hwithMinor.snoc majorType'
+    have htypeFnMinor :
+        (typeFn.liftN 2).inst minor 1 = typeFn.lift := by
+      rw [← VExpr.liftN_liftN typeFn 1 1,
+        VExpr.instN_liftAt_projection, VExpr.inst_lift]
+    have hminorVar : VExpr.instVar 0 minor 1 = .bvar 0 := by
+      simp [VExpr.instVar]
+    have hresult :
+        (((typeFn.liftN 2).app (.bvar 0)).inst minor 1).inst major =
+          typeFn.app major := by
+      simp only [VExpr.inst]
+      rw [htypeFnMinor, VExpr.inst_lift]
+      rw [hminorVar]
+      simp only [VExpr.inst]
+      rw [VExpr.instVar_zero]
+    rw [hresult] at hout
+    simpa [List.append_assoc] using hout
+  exact hwithMajor.hasType_appN hrec
+
+theorem SpineWF.instNProjection {env : VEnv} {U k : Nat}
+    {Γ₀ Γ₁ Γ : List VExpr} {e₀ A₀ : VExpr}
+    (henv : env.Ordered)
+    (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (h₀ : env.HasType U Γ₀ e₀ A₀) :
+    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ₁ A es B →
+      env.SpineWF U Γ (A.inst e₀ k)
+        (es.map fun e => e.inst e₀ k) (B.inst e₀ k)
+  | _, _, _, h => h.instN henv W h₀
+
+/-- A generated projector computes on the matching generated constructor
+once the registered rule's capture spine has been checked.  This is the
+exact iota layer; constructor-head and parameter-prefix alignment are kept
+outside this theorem. -/
+theorem _root_.Lean4Lean.VStructureView.WF.projector_constructor_exact
+    (self : VStructureView.WF view env) (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U))
+    {levels : List VLevel} (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = view.uvars)
+    {params : List VExpr} (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      env.SpineWF U Γ (view.familyType.instL levels)
+        params (.sort resultLevel))
+    {idx : Nat} {code : VStructureView.ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[idx]? = some code)
+    (hprojector : env.HasType U Γ code.projector
+      (.forallE (view.structureType levels params)
+        (.app code.typeFn.lift (.bvar 0))))
+    {fields : List VExpr} (hfieldsLength :
+      fields.length = (view.specializedFields levels params).length)
+    {field : VExpr} (hfield : fields[idx]? = some field)
+    (hctorType : env.HasType U Γ
+      (VExpr.appN (.const view.constructorName levels) (params ++ fields))
+      (view.structureType levels params))
+    (hfieldsSpine : env.SpineWF U Γ
+      (VExpr.forallN (view.specializedFields levels params) (.sort .zero))
+      fields (.sort .zero))
+    {B : VExpr}
+    (hcaps : env.SpineWF U Γ
+      ((view.generation.rule 0 view.constructor).type.instL
+        (view.projectionLevels code.fieldSort levels))
+      (params ++ [code.typeFn, code.minor] ++ fields) B) :
+    env.IsDefEqU U Γ
+      (.app code.projector
+        (VExpr.appN (.const view.constructorName levels) (params ++ fields)))
+      field := by
+  obtain ⟨fieldSort, hfieldSort, hcodeSort, hminorShape,
+      hprojectorShape⟩ :=
+    view.projectionCodes_get?_program_shape levels params hcode
+  have hsortTel := self.specializedFields_onSortTel henv.ordered
+    levels hlevels hlevelsLength params hparamsLength hparamsSpine
+  have hfieldSortWF : code.fieldSort.WF U := by
+    rw [hcodeSort]
+    exact hsortTel.sortWF hΓ hfieldSort
+  let pLevels := view.projectionLevels code.fieldSort levels
+  have hpLevelsWF : ∀ level ∈ pLevels, level.WF U :=
+    VStructureView.projectionLevels_wf view code.fieldSort levels
+      hfieldSortWF hlevels
+  have hpLevelsLength : pLevels.length = view.generation.recUvars :=
+    VStructureView.projectionLevels_length view code.fieldSort levels
+      hlevelsLength
+  have hruleMem : view.generation.rule 0 view.constructor ∈
+      view.generation.generatedRules := by
+    simp [VInductDecl.GenerationChecked.generatedRules,
+      view.constructor_eq]
+  have hregistered := self.rule_mem hruleMem
+  have hruleWF := henv.ordered.defEqWF hregistered
+  rw [hprojectorShape] at hprojector
+  obtain ⟨_, ⟨projectorBodyType, hprojectorBody⟩⟩ :=
+    hprojector.lam_inv henv.ordered hΓ
+  have hprojectorBeta := VEnv.IsDefEq.beta hprojectorBody hctorType
+  have hprojectorToRule : env.IsDefEqU U Γ
+      (.app code.projector
+        (VExpr.appN (.const view.constructorName levels) (params ++ fields)))
+      (VExpr.appN (.const view.recursorName pLevels)
+        (params ++ [code.typeFn, code.minor,
+          VExpr.appN (.const view.constructorName levels)
+            (params ++ fields)])) := by
+    refine ⟨projectorBodyType.inst
+      (VExpr.appN (.const view.constructorName levels) (params ++ fields)), ?_⟩
+    rw [hprojectorShape]
+    simpa [pLevels, VExpr.inst, VExpr.instN_appN, VExpr.inst_lift,
+      VExpr.instVar_zero,
+      List.map_append, List.map_map, Function.comp_def] using
+        hprojectorBeta
+  let gen := view.generation
+  let Bs := view.constructor.fieldsR view.source.uvars view.source.nparams
+    gen.elimination
+  let m := Bs.length
+  let rs := view.constructor.recArgsR view.source.uvars gen.elimination
+  let binders := gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++
+    VExpr.liftTelN (gen.block.ctorPairs.length + 1) Bs 0
+  let recBase := VExpr.appN
+    (.const (.str gen.block.sourceType.name "rec") gen.recLevels)
+    (VExpr.bvarRevRange m (view.source.nparams +
+      gen.block.ctorPairs.length + 1))
+  let idxR := view.constructor.resultIndicesR view.source.uvars
+    gen.elimination |>.map fun expression =>
+      expression.liftN (gen.block.ctorPairs.length + 1) m
+  let ctorApp := VExpr.appN
+    (.const view.constructor.raw.name gen.sourceLevels)
+    (VExpr.bvarRevRange (m + gen.block.ctorPairs.length + 1)
+        view.source.nparams ++ VExpr.bvarRevRange 0 m)
+  let ihs := rs.map fun recursive =>
+    recursive.ruleCall m gen.block.ctorPairs.length recBase
+  let lhsBody := VExpr.appN recBase (idxR ++ [ctorApp])
+  let rhsBody := VExpr.appN
+    (.bvar (gen.block.ctorPairs.length - 1 - 0 + m))
+    (VExpr.bvarRevRange 0 m ++ ihs)
+  let typeBody := VExpr.appN
+    (.bvar (gen.block.ctorPairs.length + m)) (idxR ++ [ctorApp])
+  have hlhs₀ := hruleWF.1
+  change env.HasType gen.recUvars [] (VExpr.lamN binders lhsBody)
+    (VExpr.forallN binders typeBody) at hlhs₀
+  have hrhs₀ := hruleWF.2
+  change env.HasType gen.recUvars [] (VExpr.lamN binders rhsBody)
+    (VExpr.forallN binders typeBody) at hrhs₀
+  have hlhs : env.HasType U Γ
+      ((VExpr.lamN binders lhsBody).instL pLevels)
+      ((VExpr.forallN binders typeBody).instL pLevels) :=
+    (hlhs₀.instL hpLevelsWF).weak0 henv.ordered
+  have hrhs : env.HasType U Γ
+      ((VExpr.lamN binders rhsBody).instL pLevels)
+      ((VExpr.forallN binders typeBody).instL pLevels) :=
+    (hrhs₀.instL hpLevelsWF).weak0 henv.ordered
+  rw [VExpr.instL_lamN, VExpr.instL_forallN] at hlhs hrhs
+  have hcaps' : env.SpineWF U Γ
+      (VExpr.forallN (binders.map (VExpr.instL pLevels))
+        (typeBody.instL pLevels))
+      (params ++ [code.typeFn, code.minor] ++ fields) B := by
+    change env.SpineWF U Γ
+      ((VExpr.forallN binders typeBody).instL pLevels)
+      (params ++ [code.typeFn, code.minor] ++ fields) B at hcaps
+    simpa only [VExpr.instL_forallN] using hcaps
+  let S := self.toGenerationEnv henv.ordered
+  have hparamsTelLength : gen.paramsTel.length = view.nparams := by
+    simp [gen, VInductDecl.GenerationChecked.paramsTel,
+      S.generationParams_length]
+  have hspecializedLength :
+      (view.specializedFields levels params).length =
+        (view.constructor.rawFields view.nparams).length := by
+    simp [VStructureView.specializedFields, VStructureView.fields]
+  have hBsLength : Bs.length =
+      (view.constructor.rawFields view.nparams).length := by
+    simpa [Bs] using
+      (VInductDecl.NormalizedCtor.fieldsR_length
+        (source := view.source) view.constructor
+        (mode := gen.elimination))
+  have hcapturesLength :
+      (params ++ [code.typeFn, code.minor] ++ fields).length =
+        (binders.map (VExpr.instL pLevels)).length := by
+    simp only [List.length_append, List.length_cons, List.length_nil,
+      List.length_map, VExpr.liftTelN_length, binders]
+    rw [hparamsLength, hfieldsLength, hspecializedLength,
+      hparamsTelLength, gen.minorTypes_length, view.constructor_eq,
+      hBsLength]
+    simp
+  obtain ⟨hlhsTel, lhsType, hlhsBody⟩ :=
+    VEnv.HasType.lamN_wf henv.ordered hΓ hlhs
+  obtain ⟨hrhsTel, rhsType, hrhsBody⟩ :=
+    VEnv.HasType.lamN_wf henv.ordered hΓ hrhs
+  have hlhsSpine := hcaps'.retarget hcapturesLength lhsType
+  have hrhsSpine := hcaps'.retarget hcapturesLength rhsType
+  have hcollapseL := VEnv.IsDefEq.appN_lamN henv.ordered
+    hlhsTel hlhsBody hlhsSpine hcapturesLength
+  have hcollapseR := VEnv.IsDefEq.appN_lamN henv.ordered
+    hrhsTel hrhsBody hrhsSpine hcapturesLength
+  have hregisteredRule : env.IsDefEq U Γ
+      ((view.generation.rule 0 view.constructor).lhs.instL pLevels)
+      ((view.generation.rule 0 view.constructor).rhs.instL pLevels)
+      ((view.generation.rule 0 view.constructor).type.instL pLevels) :=
+    .extra hregistered hpLevelsWF hpLevelsLength
+  have happlied := VEnv.IsDefEq.appN_congr hregisteredRule hcaps
+  rw [show (view.generation.rule 0 view.constructor).lhs =
+      VExpr.lamN binders lhsBody from rfl,
+    show (view.generation.rule 0 view.constructor).rhs =
+      VExpr.lamN binders rhsBody from rfl,
+    VExpr.instL_lamN] at happlied
+  simp only [VExpr.instL_lamN] at happlied
+  have hiotaBodies : env.IsDefEqU U Γ
+      (VExpr.instRev (lhsBody.instL pLevels)
+        (params ++ [code.typeFn, code.minor] ++ fields))
+      (VExpr.instRev (rhsBody.instL pLevels)
+        (params ++ [code.typeFn, code.minor] ++ fields)) :=
+    VEnv.IsDefEqU.trans henv hΓ ⟨_, hcollapseL.symm⟩
+      (VEnv.IsDefEqU.trans henv hΓ ⟨_, happlied⟩ ⟨_, hcollapseR⟩)
+  have hconstructorMem : view.constructor ∈
+      view.generation.block.ctorPairs := by
+    simp [view.constructor_eq]
+  have hresultIndices : view.constructor.view.resultIndices = [] := by
+    apply List.length_eq_zero_iff.1
+    rw [S.viewResultIndices_length hconstructorMem]
+    simp [view.checked_indices_eq]
+  have hfieldsLengthRaw : fields.length = m := by
+    exact hfieldsLength.trans (hspecializedLength.trans hBsLength.symm)
+  have hprefixLength :
+      (params ++ [code.typeFn, code.minor]).length = view.nparams + 2 := by
+    simp [hparamsLength]
+  have hcapturesLength' :
+      (params ++ [code.typeFn, code.minor] ++ fields).length =
+        view.nparams + 2 + m := by
+    simp [hparamsLength, hfieldsLengthRaw]
+    omega
+  have hsegCommon :
+      (VExpr.bvarRevRange m (view.nparams + 2)).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) =
+        params ++ [code.typeFn, code.minor] := by
+    have h := VExpr.map_instRev_bvarRevRange_seg
+      (params ++ [code.typeFn, code.minor] ++ fields)
+      (view.nparams + 2) m (by rw [hcapturesLength']; omega)
+    rw [← hparamsLength] at h ⊢
+    rw [show (params ++ [code.typeFn, code.minor] ++ fields).length -
+        m - (params.length + 2) = 0 by
+          simp only [List.length_append, List.length_cons, List.length_nil]
+          rw [hfieldsLengthRaw]
+          omega,
+      List.drop_zero] at h
+    rw [List.take_append,
+      show params.length + 2 =
+        (params ++ [code.typeFn, code.minor]).length by simp,
+      List.take_length] at h
+    simpa using h
+  have hsegParams :
+      (VExpr.bvarRevRange (m + 2) view.nparams).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) = params := by
+    have h := VExpr.map_instRev_bvarRevRange_seg
+      (params ++ [code.typeFn, code.minor] ++ fields)
+      view.nparams (m + 2) (by rw [hcapturesLength']; omega)
+    rw [← hparamsLength] at h ⊢
+    rw [show (params ++ [code.typeFn, code.minor] ++ fields).length -
+        (m + 2) - params.length = 0 by
+          simp only [List.length_append, List.length_cons, List.length_nil]
+          rw [hfieldsLengthRaw]
+          omega,
+      List.drop_zero] at h
+    simpa using h
+  have hsegFields :
+      (VExpr.bvarRevRange 0 m).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) = fields := by
+    have h := VExpr.map_instRev_bvarRevRange_seg
+      (params ++ [code.typeFn, code.minor] ++ fields) m 0
+      (by rw [hcapturesLength']; omega)
+    rw [show (params ++ [code.typeFn, code.minor] ++ fields).length -
+        0 - m = view.nparams + 2 by rw [hcapturesLength']; omega,
+      show view.nparams + 2 =
+        (params ++ [code.typeFn, code.minor]).length by
+          exact hprefixLength.symm,
+      List.drop_left] at h
+    have htake : fields.take m = fields :=
+      List.take_of_length_le (Nat.le_of_eq hfieldsLengthRaw)
+    rw [htake] at h
+    exact h
+  have hsourceLevels := VStructureView.sourceLevels_projectionLevels
+    view code.fieldSort levels hlevelsLength
+  have hrecLevels : gen.recLevels.map (VLevel.inst pLevels) = pLevels := by
+    exact VLevel.inst_map_id hpLevelsLength
+  have hrecConst :
+      VExpr.instRev
+          ((.const (.str gen.block.sourceType.name "rec") gen.recLevels :
+            VExpr).instL pLevels)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        .const view.recursorName pLevels := by
+    rw [VExpr.instRev_closedN _ (by trivial)]
+    simp only [VExpr.instL]
+    rw [hrecLevels]
+    rfl
+  have hsegCommonL :
+      (VExpr.bvarRevRange m (view.nparams + 2)).map
+          (fun expression => VExpr.instRev (expression.instL pLevels)
+            (params ++ [code.typeFn, code.minor] ++ fields)) =
+        params ++ [code.typeFn, code.minor] := by
+    calc
+      _ = ((VExpr.bvarRevRange m (view.nparams + 2)).map
+            (VExpr.instL pLevels)).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) := by
+          rw [List.map_map]
+          exact List.map_congr_left fun _ _ => rfl
+      _ = _ := by
+        rw [VExpr.bvarRevRange_map_instL]
+        exact hsegCommon
+  have hsegParamsL :
+      (VExpr.bvarRevRange (m + 2) view.nparams).map
+          (fun expression => VExpr.instRev (expression.instL pLevels)
+            (params ++ [code.typeFn, code.minor] ++ fields)) = params := by
+    calc
+      _ = ((VExpr.bvarRevRange (m + 2) view.nparams).map
+            (VExpr.instL pLevels)).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) := by
+          rw [List.map_map]
+          exact List.map_congr_left fun _ _ => rfl
+      _ = _ := by
+        rw [VExpr.bvarRevRange_map_instL]
+        exact hsegParams
+  have hsegFieldsL :
+      (VExpr.bvarRevRange 0 m).map
+          (fun expression => VExpr.instRev (expression.instL pLevels)
+            (params ++ [code.typeFn, code.minor] ++ fields)) = fields := by
+    calc
+      _ = ((VExpr.bvarRevRange 0 m).map
+            (VExpr.instL pLevels)).map
+          (VExpr.instRev ·
+            (params ++ [code.typeFn, code.minor] ++ fields)) := by
+          rw [List.map_map]
+          exact List.map_congr_left fun _ _ => rfl
+      _ = _ := by
+        rw [VExpr.bvarRevRange_map_instL]
+        exact hsegFields
+  have hidxRNil : idxR = [] := by
+    simp [idxR, VInductDecl.NormalizedCtor.resultIndicesR,
+      hresultIndices]
+  have hrecBaseShape :
+      VExpr.instRev (recBase.instL pLevels)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        VExpr.appN (.const view.recursorName pLevels)
+          (params ++ [code.typeFn, code.minor]) := by
+    rw [show recBase = VExpr.appN
+        (.const (.str gen.block.sourceType.name "rec") gen.recLevels)
+        (VExpr.bvarRevRange m (view.nparams + 2)) by
+          unfold recBase
+          rw [view.constructor_eq]
+          rfl,
+      VExpr.instL_appN, VExpr.instRev_appN, hrecConst]
+    rw [List.map_map]
+    exact congrArg (VExpr.appN (.const view.recursorName pLevels))
+      hsegCommonL
+  have hctorShape :
+      VExpr.instRev (ctorApp.instL pLevels)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        VExpr.appN (.const view.constructorName levels)
+          (params ++ fields) := by
+    rw [show ctorApp = VExpr.appN
+        (.const view.constructorName gen.sourceLevels)
+        (VExpr.bvarRevRange (m + 2) view.nparams ++
+          VExpr.bvarRevRange 0 m) by
+          unfold ctorApp
+          rw [view.constructor_eq]
+          rfl,
+      VExpr.instL_appN, VExpr.instRev_appN]
+    rw [VExpr.instRev_closedN _ (by trivial)]
+    simp only [VExpr.instL]
+    rw [hsourceLevels]
+    simp only [List.map_append, List.map_map, Function.comp_def]
+    rw [hsegParamsL, hsegFieldsL]
+  have hleftShape :
+      VExpr.instRev (lhsBody.instL pLevels)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        VExpr.appN (.const view.recursorName pLevels)
+          (params ++ [code.typeFn, code.minor,
+            VExpr.appN (.const view.constructorName levels)
+              (params ++ fields)]) := by
+    rw [show lhsBody = VExpr.appN recBase (idxR ++ [ctorApp]) by
+          rfl,
+      VExpr.instL_appN, VExpr.instRev_appN, hrecBaseShape, hidxRNil,
+      List.nil_append]
+    simp only [List.map_cons, List.map_nil, hctorShape]
+    rw [← VExpr.appN_append]
+    simp only [List.append_assoc]
+    rfl
+  have hminorCapture :
+      VExpr.instRev (.bvar m)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        code.minor := by
+    have h := VExpr.map_instRev_bvarRevRange_seg
+      (params ++ [code.typeFn, code.minor] ++ fields) 1 m
+      (by rw [hcapturesLength']; omega)
+    rw [show (params ++ [code.typeFn, code.minor] ++ fields).length -
+        m - 1 = params.length + 1 by
+          rw [hcapturesLength', hparamsLength]
+          omega] at h
+    simpa [VExpr.bvarRevRange] using h
+  have hrightBodyShape :
+      rhsBody = VExpr.appN (.bvar m) (VExpr.bvarRevRange 0 m) := by
+    simp [rhsBody, ihs, rs, gen,
+      VInductDecl.NormalizedCtor.recArgsR, view.recursive_eq,
+      view.constructor_eq]
+  have hrightShape :
+      VExpr.instRev (rhsBody.instL pLevels)
+          (params ++ [code.typeFn, code.minor] ++ fields) =
+        VExpr.appN code.minor fields := by
+    rw [hrightBodyShape, VExpr.instL_appN,
+      VExpr.bvarRevRange_map_instL, VExpr.instRev_appN]
+    simp only [VExpr.instL]
+    rw [hminorCapture, hsegFields]
+  rw [hleftShape, hrightShape] at hiotaBodies
+  obtain ⟨selectedType, hselectedType, -⟩ :=
+    view.projectionCodes_get?_typeFn levels params hcode
+  have hidxLt : idx < (view.specializedFields levels params).length :=
+    (List.getElem?_eq_some_iff.1 hselectedType).1
+  let q := (view.specializedFields levels params).length - 1 - idx
+  have hqLt : q < (view.specializedFields levels params).length := by
+    simp only [q]
+    omega
+  have hselectedReverse :
+      (view.specializedFields levels params).reverse[q]? =
+        some selectedType := by
+    rw [List.getElem?_reverse hqLt,
+      show (view.specializedFields levels params).length - 1 - q = idx by
+        simp only [q]
+        omega,
+      hselectedType]
+  have hselectedCtx :
+      ((view.specializedFields levels params).reverse ++ Γ)[q]? =
+        some selectedType := by
+    rw [List.getElem?_append_left (by simpa using hqLt),
+      hselectedReverse]
+  have hminorBodyType : env.HasType U
+      ((view.specializedFields levels params).reverse ++ Γ)
+      (.bvar q) (selectedType.liftN (q + 1)) :=
+    .bvar (Lookup.of_getElem? hselectedCtx)
+  have hminorSpine := hfieldsSpine.retarget hfieldsLength
+    (selectedType.liftN (q + 1))
+  have hminorBetaRaw := VEnv.IsDefEq.appN_lamN henv.ordered
+    hsortTel.toOnTel hminorBodyType hminorSpine hfieldsLength
+  have hfieldInst : VExpr.instRev (.bvar q) fields = field := by
+    have h := VExpr.map_instRev_bvarRevRange_seg fields 1 q
+      (by rw [hfieldsLength]; exact Nat.add_one_le_iff.2 hqLt)
+    rw [show fields.length - q - 1 = idx by
+      rw [hfieldsLength]
+      simp only [q]
+      omega] at h
+    obtain ⟨hidxFields, hfieldGet⟩ :=
+      List.getElem?_eq_some_iff.1 hfield
+    rw [List.drop_eq_getElem_cons hidxFields, hfieldGet,
+      List.take_succ_cons] at h
+    simpa [VExpr.bvarRevRange] using h
+  have hminorBeta : env.IsDefEqU U Γ
+      (VExpr.appN code.minor fields) field := by
+    refine ⟨VExpr.instRev (selectedType.liftN (q + 1)) fields, ?_⟩
+    rw [hminorShape]
+    simpa only [hfieldInst] using hminorBetaRaw
+  exact VEnv.IsDefEqU.trans henv hΓ hprojectorToRule
+    (VEnv.IsDefEqU.trans henv hΓ hiotaBodies hminorBeta)
+
+/-- Environment-indexed projection semantics.
+
+The universe and parameter spines are explicit.  The major premise must have
+the exact instantiated structure type, and the result is the unique program
+computed by the registered view. -/
+structure TrProj (env : VEnv) (U : Nat) (Γ : List VExpr)
+    (view : VStructureView) (levels : List VLevel) (params : List VExpr)
+    (idx : Nat) (major result : VExpr) : Prop where
+  viewWF : VStructureView.WF view env
+  levelsWF : ∀ level ∈ levels, level.WF U
+  levels_length : levels.length = view.uvars
+  params_length : params.length = view.nparams
+  paramsSpine : ∃ resultLevel,
+    env.SpineWF U Γ (view.familyType.instL levels)
+      params (.sort resultLevel)
+  majorType : env.HasType U Γ major (view.structureType levels params)
+  program : ∃ code : VStructureView.ProjectionCode,
+    (view.projectionCodes levels params)[idx]? = some code ∧
+      result = .app code.projector major ∧
+      env.HasType U Γ code.projector
+        (.forallE (view.structureType levels params)
+          (.app code.typeFn.lift (.bvar 0)))
+
+/-- The projection-specific output of registered constructor-head inversion.
+
+This package performs no iota computation.  It only aligns a constructor
+normal form and one selected runtime argument with the canonical registered
+view, and supplies the typed spines needed by
+`projector_constructor_exact`. -/
+structure ProjectionConstructorAlignment (env : VEnv) (U : Nat)
+    (Γ : List VExpr) (view : VStructureView) (levels : List VLevel)
+    (params : List VExpr) (idx : Nat)
+    (code : VStructureView.ProjectionCode)
+    (runtimeConstructorName : Name) (runtimeMajor runtimeField : VExpr) where
+  constructor_name_eq : runtimeConstructorName = view.constructorName
+  fields : List VExpr
+  field : VExpr
+  fields_length :
+    fields.length = (view.specializedFields levels params).length
+  field_get : fields[idx]? = some field
+  constructorType : env.HasType U Γ
+    (VExpr.appN (.const view.constructorName levels) (params ++ fields))
+    (view.structureType levels params)
+  fieldsSpine : env.SpineWF U Γ
+    (VExpr.forallN (view.specializedFields levels params) (.sort .zero))
+    fields (.sort .zero)
+  captures : ∃ B, env.SpineWF U Γ
+    ((view.generation.rule 0 view.constructor).type.instL
+      (view.projectionLevels code.fieldSort levels))
+    (params ++ [code.typeFn, code.minor] ++ fields) B
+  major_eq : env.IsDefEqU U Γ runtimeMajor
+    (VExpr.appN (.const view.constructorName levels) (params ++ fields))
+  field_eq : env.IsDefEqU U Γ runtimeField field
+
+/-- Consume registered-head alignment with the separately proved exact iota
+theorem.  This keeps the transitional injectivity boundary from hiding the
+projection computation itself. -/
+theorem TrProj.projector_constructor_aligned
+    (self : VEnv.TrProj env U Γ view levels params idx major result)
+    (henv : env.WF) (hΓ : OnCtx Γ (env.IsType U))
+    {code : VStructureView.ProjectionCode}
+    (hcode : (view.projectionCodes levels params)[idx]? = some code)
+    (hprojector : env.HasType U Γ code.projector
+      (.forallE (view.structureType levels params)
+        (.app code.typeFn.lift (.bvar 0))))
+    {runtimeMajor runtimeField : VExpr}
+    {runtimeConstructorName : Name}
+    (alignment : ProjectionConstructorAlignment env U Γ view levels params idx
+      code runtimeConstructorName runtimeMajor runtimeField) :
+    env.IsDefEqU U Γ (.app code.projector runtimeMajor) runtimeField := by
+  have hmajorEq := alignment.major_eq.of_r henv hΓ
+    alignment.constructorType
+  have hmajorCongr : env.IsDefEqU U Γ
+      (.app code.projector runtimeMajor)
+      (.app code.projector
+        (VExpr.appN (.const view.constructorName levels)
+          (params ++ alignment.fields))) :=
+    ⟨_, hprojector.appDF hmajorEq⟩
+  obtain ⟨captureType, hcaptures⟩ := alignment.captures
+  have hiota := self.viewWF.projector_constructor_exact henv hΓ
+    self.levelsWF self.levels_length self.params_length self.paramsSpine
+    hcode hprojector alignment.fields_length alignment.field_get
+    alignment.constructorType alignment.fieldsSpine hcaptures
+  exact VEnv.IsDefEqU.trans henv hΓ hmajorCongr
+    (VEnv.IsDefEqU.trans henv hΓ hiota alignment.field_eq.symm)
+
+theorem TrProj.project_eq
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    VStructureView.project? view levels params idx major = some result := by
+  obtain ⟨code, hcode, rfl, -⟩ := self.program
+  simp [VStructureView.project?, hcode]
+
+theorem TrProj.type_eq
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    ∃ code : VStructureView.ProjectionCode,
+      VStructureView.projectionType? view levels params idx major =
+        some (VExpr.app code.typeFn major) := by
+  obtain ⟨code, hcode, _, -⟩ := self.program
+  exact ⟨code, by simp [VStructureView.projectionType?, hcode]⟩
+
+/-- A fixed checked view, universe/parameter instantiation, field index, and
+major determine the projection result syntactically. -/
+theorem TrProj.result_eq
+    (self : VEnv.TrProj env U Γ view levels params idx major result)
+    (other : VEnv.TrProj env U Γ view levels params idx major result') :
+    result = result' :=
+  Option.some.inj (self.project_eq.symm.trans other.project_eq)
+
+/-- Projection evidence is stable when the registered environment is
+extended without changing any existing constants or reduction rules. -/
+theorem TrProj.mono {env env' : VEnv} (henv : env ≤ env')
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    VEnv.TrProj env' U Γ view levels params idx major result where
+  viewWF := self.viewWF.mono henv
+  levelsWF := self.levelsWF
+  levels_length := self.levels_length
+  params_length := self.params_length
+  paramsSpine := self.paramsSpine.imp fun _ h => h.monoProjection henv
+  majorType := self.majorType.mono henv
+  program := self.program.imp fun code ⟨hcode, hresult, htype⟩ =>
+    ⟨hcode, hresult, htype.mono henv⟩
+
+/-- Weakening acts pointwise on the explicit parameters, major, and computed
+projection program. -/
+theorem TrProj.weakN (henv : env.Ordered)
+    (W : Ctx.LiftN n k Γ Γ')
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    VEnv.TrProj env U Γ' view levels
+      (params.map fun param => param.liftN n k) idx
+      (major.liftN n k) (result.liftN n k) := by
+  refine {
+    viewWF := self.viewWF
+    levelsWF := self.levelsWF
+    levels_length := self.levels_length
+    params_length := by simpa using self.params_length
+    paramsSpine := ?_
+    majorType := by simpa using self.majorType.weakN henv W
+    program := ?_ }
+  · have hfamilyClosed : (view.familyType.instL levels).ClosedN 0 := by
+      simpa using (henv.closedC self.viewWF.family).instL
+    obtain ⟨resultLevel, hspine⟩ := self.paramsSpine
+    refine ⟨resultLevel, ?_⟩
+    have hspine' := hspine.weakN henv W
+    rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine'
+    simpa [VExpr.liftN] using hspine'
+  · obtain ⟨code, hcode, rfl, htype⟩ := self.program
+    refine ⟨code.liftN n k, ?_, rfl, ?_⟩
+    rw [← self.viewWF.projectionCodes_liftN henv levels params
+      self.params_length n k]
+    simp only [List.getElem?_map, hcode, Option.map_some]
+    simpa [VStructureView.ProjectionCode.liftN, VExpr.liftN,
+      VExpr.liftN_lift_projection] using htype.weakN henv W
+
+/-- General context lifting, derived one inserted binder at a time from
+`weakN`. -/
+theorem TrProj.weak' (henv : env.Ordered)
+    (W : Ctx.Lift' l Γ Γ')
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    VEnv.TrProj env U Γ' view levels
+      (params.map fun param => param.lift' l) idx
+      (major.lift' l) (result.lift' l) := by
+  generalize hdepth : l.depth = depth
+  induction depth generalizing l Γ' with
+  | zero =>
+      have hctx := W.depth_zero hdepth
+      subst Γ'
+      simpa [VExpr.lift'_depth_zero (l := l) hdepth] using self
+  | succ depth ih =>
+      obtain ⟨tail, k, rfl, rfl⟩ := Lift.depth_succ hdepth
+      obtain ⟨Γ₁, W₁, W₂⟩ := W.of_cons_skip
+      have h := (ih W₁ Lift.depth_consN).weakN henv W₂
+      rw [Lift.consN_skip_eq]
+      have hlift : ∀ e : VExpr,
+          e.lift' ((tail.consN k).comp
+              (Lift.refl.skip.consN k)) =
+            (e.lift' (tail.consN k)).liftN 1 k := by
+        intro e
+        rw [VExpr.lift'_comp, ← Lift.skipN_one,
+          VExpr.lift'_consN_skipN]
+      have hparams :
+          params.map (fun param => param.lift' ((tail.consN k).comp
+              (Lift.refl.skip.consN k))) =
+            (params.map fun param => param.lift' (tail.consN k)).map
+              (fun param => param.liftN 1 k) := by
+        rw [List.map_map]
+        exact List.map_congr_left fun param _ => hlift param
+      rw [hparams, hlift major, hlift result]
+      exact h
+
+/-- Substitution acts pointwise on the explicit parameters, major, and
+computed projection program. -/
+theorem TrProj.instN (henv : env.Ordered)
+    (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (h₀ : env.HasType U Γ₀ e₀ A₀)
+    (self : VEnv.TrProj env U Γ₁ view levels params idx major result) :
+    VEnv.TrProj env U Γ view levels
+      (params.map fun param => param.inst e₀ k) idx
+      (major.inst e₀ k) (result.inst e₀ k) := by
+  refine {
+    viewWF := self.viewWF
+    levelsWF := self.levelsWF
+    levels_length := self.levels_length
+    params_length := by simpa using self.params_length
+    paramsSpine := ?_
+    majorType := by simpa using self.majorType.instN henv W h₀
+    program := ?_ }
+  · have hfamilyClosed : (view.familyType.instL levels).ClosedN 0 := by
+      simpa using (henv.closedC self.viewWF.family).instL
+    obtain ⟨resultLevel, hspine⟩ := self.paramsSpine
+    refine ⟨resultLevel, ?_⟩
+    have hspine' := hspine.instNProjection henv W h₀
+    rw [hfamilyClosed.instN_eq (Nat.zero_le _)] at hspine'
+    simpa [VExpr.inst] using hspine'
+  · obtain ⟨code, hcode, rfl, htype⟩ := self.program
+    refine ⟨code.instN e₀ k, ?_, rfl, ?_⟩
+    rw [← self.viewWF.projectionCodes_instN henv levels params
+      self.params_length e₀ k]
+    simp only [List.getElem?_map, hcode, Option.map_some]
+    simpa [VStructureView.ProjectionCode.instN, VExpr.inst,
+      ← VExpr.lift_instN_lo] using htype.instN henv W h₀
+
+/-- Transport projection evidence to a definitionally equal context and a
+new major already checked against the same instantiated structure type. -/
+theorem TrProj.defeqDFC (henv : env.Ordered)
+    (hΓ : env.IsDefEqCtx U Γ₀ Γ₁ Γ₂)
+    (majorType' : env.HasType U Γ₂ major'
+      (view.structureType levels params))
+    (self : VEnv.TrProj env U Γ₁ view levels params idx major result) :
+    ∃ result', VEnv.TrProj env U Γ₂ view levels params idx major' result' := by
+  obtain ⟨code, hcode, -, htype⟩ := self.program
+  refine ⟨.app code.projector major', {
+    viewWF := self.viewWF
+    levelsWF := self.levelsWF
+    levels_length := self.levels_length
+    params_length := self.params_length
+    paramsSpine := self.paramsSpine.imp fun _ h => h.defeqDFC henv hΓ
+    majorType := majorType'
+    program := ⟨code, hcode, rfl,
+      htype.defeqDFC henv hΓ⟩ }⟩
+
+/-- Universe instantiation acts pointwise on the explicit structure
+universes and parameters, and on the recursor program they determine. -/
+theorem TrProj.instL {ls : List VLevel}
+    (hls : ∀ level ∈ ls, level.WF U')
+    (self : VEnv.TrProj env U Γ view levels params idx major result) :
+    VEnv.TrProj env U' (Γ.map (VExpr.instL ls)) view
+      (levels.map (VLevel.inst ls))
+      (params.map (VExpr.instL ls)) idx
+      (major.instL ls) (result.instL ls) := by
+  refine {
+    viewWF := self.viewWF
+    levelsWF := ?_
+    levels_length := by simpa using self.levels_length
+    params_length := by simpa using self.params_length
+    paramsSpine := ?_
+    majorType := by simpa using self.majorType.instL hls
+    program := ?_ }
+  · intro level hlevel
+    obtain ⟨sourceLevel, hsourceLevel, rfl⟩ := List.mem_map.1 hlevel
+    exact VLevel.WF.inst hls
+  · obtain ⟨resultLevel, hspine⟩ := self.paramsSpine
+    refine ⟨resultLevel.inst ls, ?_⟩
+    simpa [VExpr.instL, VExpr.instL_instL] using hspine.instL hls
+  · obtain ⟨code, hcode, rfl, htype⟩ := self.program
+    refine ⟨code.instL ls, ?_, ?_, ?_⟩
+    · rw [← VStructureView.projectionCodes_instL]
+      simp only [List.getElem?_map, hcode, Option.map_some]
+    · rfl
+    · simpa [VStructureView.ProjectionCode.instL, VExpr.instL,
+        VExpr.instL_liftN] using htype.instL hls
+
+/-- The registered-structure constant-head inversion boundary.
+
+The four conclusions are the projection-specific eliminators supplied by
+constant-head injectivity: a type assigned to a syntactically weakened major
+recovers an instantiation below the inserted context; definitionally equal
+majors recover the same registered view/instantiation strongly enough for the
+generated projector programs to be definitionally equal; a runtime
+constructor head recovers the registered constructor name; and that head plus
+one selected argument is aligned with the registered constructor and field.
+The last conclusion deliberately provides only typed alignment—the iota step
+remains the proved `projector_constructor_exact` theorem.
+
+Its eventual proof uses `IsDefEqU.weakN_iff` together with injectivity of
+registered inductive heads.  Keeping the boundary in Theory makes the
+temporary L4L-16/17 dependency explicit instead of leaving Verify's
+structural laws as local holes. -/
+structure RegisteredStructureHeadInversion (env : VEnv) : Prop where
+  weak'_inv :
+    ∀ {U : Nat} {Γ Γ' : List VExpr} {view : VStructureView}
+      {levels : List VLevel} {params : List VExpr} {idx : Nat}
+      {major result : VExpr} {lift : Lift},
+      OnCtx Γ' (env.IsType U) →
+      Ctx.Lift' lift Γ Γ' →
+      env.TrProj U Γ' view levels params idx (major.lift' lift) result →
+      ∃ params' result',
+        env.TrProj U Γ view levels params' idx major result'
+  unique :
+    ∀ {U : Nat} {Γ₁ Γ₂ : List VExpr}
+      {view₁ view₂ : VStructureView}
+      {levels₁ levels₂ : List VLevel} {params₁ params₂ : List VExpr}
+      {idx : Nat} {major₁ major₂ result₁ result₂ : VExpr},
+      env.IsDefEqCtx U [] Γ₁ Γ₂ →
+      env.TrProj U Γ₁ view₁ levels₁ params₁ idx major₁ result₁ →
+      env.TrProj U Γ₂ view₂ levels₂ params₂ idx major₂ result₂ →
+      env.IsDefEqU U Γ₁ major₁ major₂ →
+      env.IsDefEqU U Γ₁ result₁ result₂
+  constructor_name_inv :
+    ∀ {U : Nat} {Γ : List VExpr} {view : VStructureView}
+      {levels : List VLevel} {params : List VExpr} {idx : Nat}
+      {major result runtimeMajor : VExpr}
+      {constructorName : Name} {constructorLevels : List VLevel}
+      {constructorArgs : List VExpr},
+      OnCtx Γ (env.IsType U) →
+      env.TrProj U Γ view levels params idx major result →
+      runtimeMajor = VExpr.appN
+        (.const constructorName constructorLevels) constructorArgs →
+      env.IsDefEqU U Γ runtimeMajor major →
+      constructorName = view.constructorName
+  constructor_inv :
+    ∀ {U : Nat} {Γ : List VExpr} {view : VStructureView}
+      {levels : List VLevel} {params : List VExpr} {idx : Nat}
+      {major result : VExpr} {code : VStructureView.ProjectionCode}
+      {runtimeMajor runtimeField : VExpr}
+      {constructorName : Name} {constructorLevels : List VLevel}
+      {constructorArgs : List VExpr},
+      OnCtx Γ (env.IsType U) →
+      env.TrProj U Γ view levels params idx major result →
+      (view.projectionCodes levels params)[idx]? = some code →
+      runtimeMajor = VExpr.appN
+        (.const constructorName constructorLevels) constructorArgs →
+      constructorArgs[view.nparams + idx]? = some runtimeField →
+      env.IsDefEqU U Γ runtimeMajor major →
+      Nonempty (ProjectionConstructorAlignment env U Γ view levels params idx
+        code constructorName runtimeMajor runtimeField)
+
+/-- Public Tier-R registered-head inversion statement.  L4L-16/17 discharge
+the underlying constant-head theorem; projection structural laws consume only
+this stable interface and therefore shed `sorryAx` automatically when it is
+proved. -/
+theorem WF.registeredStructureHeadInversion
+    (self : VEnv.WF env) : RegisteredStructureHeadInversion env := by
+  sorry
+
+/--
+info: 'Lean4Lean.VEnv.WF.registeredStructureHeadInversion' depends on axioms: [propext, sorryAx, Quot.sound]
+-/
+#guard_msgs in
+#print axioms WF.registeredStructureHeadInversion
+
+/--
+info: 'Lean4Lean.VEnv.TrProj.result_eq' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.result_eq
+
+/--
+info: 'Lean4Lean.VEnv.TrProj.mono' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.mono
+
+end VEnv
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/Typing/Basic.lean b/Lean4Lean/Theory/Typing/Basic.lean
index c7ae89a9..bffbe36c 100644
--- a/Lean4Lean/Theory/Typing/Basic.lean
+++ b/Lean4Lean/Theory/Typing/Basic.lean
@@ -7,6 +7,12 @@ inductive Lookup : List VExpr → Nat → VExpr → Prop where
   | zero : Lookup (ty::Γ) 0 ty.lift
   | succ : Lookup Γ n ty → Lookup (A::Γ) (n+1) ty.lift
 
+/-- A context-wide predicate, exposing each binder in its preceding context. -/
+def OnCtx (Γ : List VExpr) (P : List VExpr → VExpr → Prop) : Prop :=
+  match Γ with
+  | [] => True
+  | A::Γ => OnCtx Γ P ∧ P Γ A
+
 namespace VEnv
 
 section
@@ -15,6 +21,8 @@ local notation:65 Γ " ⊢ " e " : " A:30 => IsDefEq Γ e e A
 local notation:65 Γ " ⊢ " e1 " ≡ " e2 " : " A:30 => IsDefEq Γ e1 e2 A
 variable (env : VEnv) (uvars : Nat)
 
+mutual
+
 inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where
   | bvar : Lookup Γ i A → Γ ⊢ .bvar i : A
   | symm : Γ ⊢ e ≡ e' : A → Γ ⊢ e' ≡ e : A
@@ -48,6 +56,17 @@ inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where
   | eta :
     Γ ⊢ e : .forallE A B →
     Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B
+  | structEta :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF uvars) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    SpineWF Γ (rule.familyType.instL levels) params (.sort resultLevel) →
+    Γ ⊢ major : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major :
+      rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major ≡ major :
+      rule.structureType levels params
   | proofIrrel :
     Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p →
     Γ ⊢ h ≡ h' : p
@@ -55,6 +74,21 @@ inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where
     env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
     Γ ⊢ df.lhs.instL ls ≡ df.rhs.instL ls : df.type.instL ls
 
+/-- Typing of an application spine against an iterated pi type: peeling the
+expressions of `es` off `A` one instantiation at a time ends at `B`.
+
+This judgment is mutually inductive with `IsDefEq` so rules whose validity
+depends on an exact application spine retain induction hypotheses for every
+argument typing derivation. -/
+inductive SpineWF : List VExpr → VExpr → List VExpr → VExpr → Prop where
+  | nil : SpineWF Γ A [] A
+  | cons :
+    IsDefEq Γ e e A₁ →
+    SpineWF Γ (A₂.inst e) es B →
+    SpineWF Γ (.forallE A₁ A₂) (e :: es) B
+
+end
+
 end
 
 def HasType (env : VEnv) (U : Nat) (Γ : List VExpr) (e A : VExpr) : Prop :=
@@ -74,3 +108,26 @@ def VConstant.WF (env : VEnv) (ci : VConstant) : Prop := env.IsType ci.uvars []
 
 def VDefEq.WF (env : VEnv) (df : VDefEq) : Prop :=
   env.HasType df.uvars [] df.lhs df.type ∧ env.HasType df.uvars [] df.rhs df.type
+
+/-- Subject-reduction package attached to a registered structure-eta
+descriptor.  It consumes the exact family parameter spine but contains no
+equality premise. -/
+structure VStructEta.WF (rule : VStructEta) (env : VEnv) : Prop where
+  /-- The retained family declaration is a closed constant type.  This is the
+  syntactic fact which lets an exact parameter-spine certificate survive term
+  weakening and substitution. -/
+  familyType_closed : rule.familyType.ClosedN
+  rebuild_hasType :
+    ∀ {env' : VEnv}, env ≤ env' →
+      ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+      {params : List VExpr} {major : VExpr},
+      OnCtx Γ (env'.IsType U) →
+      (∀ level ∈ levels, level.WF U) →
+      levels.length = rule.uvars →
+      params.length = rule.nparams →
+      (∃ resultLevel,
+        env'.SpineWF U Γ (rule.familyType.instL levels)
+          params (.sort resultLevel)) →
+      env'.HasType U Γ major (rule.structureType levels params) →
+      env'.HasType U Γ (rule.rebuild levels params major)
+        (rule.structureType levels params)
diff --git a/Lean4Lean/Theory/Typing/ChurchRosser.lean b/Lean4Lean/Theory/Typing/ChurchRosser.lean
index 83e0215f..8ebfddae 100644
--- a/Lean4Lean/Theory/Typing/ChurchRosser.lean
+++ b/Lean4Lean/Theory/Typing/ChurchRosser.lean
@@ -9,6 +9,12 @@ namespace VEnv
 
 open VExpr
 
+/-- The combinatorial pattern interface used by parallel reduction.
+
+Membership and non-overlap facts classify possible contractions; they do not
+certify that a matched redex is equal to a payload. Operational soundness is
+carried by each `.extra` step, and raw registered-equation joining is supplied
+separately by `Params.Extension`. -/
 class Params where
   env : VEnv
   henv : env.WF
@@ -17,16 +23,56 @@ class Params where
   pat_simple : Pat p r → ∃ sp : SimplePattern, p = sp.toPattern
   pat_uniq : Pat p₁ r → Pat p₂ r' → Subpattern p₃ p₁ → p₂.inter p₃ = some p₄ →
     p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r'
-  pat_wf : Pat p r → p.Matches e m1 m2 → HasType env univs Γ e A →
-    r.2.OK (IsDefEqU env univs Γ) m1 m2 → IsDefEqU env univs Γ e (r.1.apply m1 m2)
   pat_app_l : Pat p r → Subpattern (.app p₁ p₂) p → ¬Subpattern (.app p₃ p₄) p₁
   pat_app_l_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
     Subpattern (.app p₁' p₂') p' → Subpattern (.var p₃) p₁ → p₁'.inter p₃ = none
   pat_app_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p →
     Subpattern (.app p₁' p₂') p' → Subpattern p₃ p₁ → Subpattern p₃' p₂' → p₃.inter p₃' = none
-  extra_pat : env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars →
-    ∃ p r m1 m2, Pat p r ∧ p.Matches (df.lhs.instL ls) m1 m2 ∧ r.2.OK (IsDefEqU env univs Γ) m1 m2 ∧
-    df.rhs.instL ls = r.1.apply m1 m2
+  /-- Registered-family typing is reflected through weakening.  This is the
+  structure-family specialization of `IsDefEqU.weakN_iff`: it retains the
+  registered head witness, which the untyped theorem intentionally erases. -/
+  structEta_weakN_inv :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF univs) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    OnCtx Γ' (env.IsType univs) →
+    Ctx.LiftN n k Γ Γ' →
+    IsDefEq env univs Γ' (e₁.liftN n k) (e₂.liftN n k)
+      (rule.structureType levels params) →
+    ∃ levels' params' resultLevel,
+      levels'.length = rule.uvars ∧
+      params'.length = rule.nparams ∧
+      (∀ level ∈ levels', level.WF univs) ∧
+      SpineWF env univs Γ (rule.familyType.instL levels') params'
+        (.sort resultLevel) ∧
+      IsDefEq env univs Γ e₁ e₂
+        (rule.structureType levels' params')
+  /-- A registered structure-family application is disjoint from the two
+  rigid type heads used by head standardization.  These are primitive head
+  coverage facts, not confluence or equality conclusions. -/
+  structEta_sort_disjoint :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF univs) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    ¬ IsDefEqU env univs Γ
+      (rule.structureType levels params) (.sort u)
+  structEta_forallE_disjoint :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF univs) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    ¬ IsDefEqU env univs Γ
+      (rule.structureType levels params) (.forallE A B)
+  /-- Function-head typing is reflected through weakening.  This is the
+  primitive head-inversion coverage needed when a residual structure-eta
+  equality is closed pointwise under ordinary function eta. -/
+  forallE_weakN_inv :
+    OnCtx Γ' (env.IsType univs) →
+    Ctx.LiftN n k Γ Γ' →
+    HasType env univs Γ' (f.liftN n k) (.forallE A B) →
+    ∃ A' B', HasType env univs Γ f (.forallE A' B')
 
 variable [Params]
 open Params
@@ -78,6 +124,63 @@ theorem _root_.Lean4Lean.Pattern.Matches.hasType {p : Pattern} {e : VExpr} {m1 m
 set_option hygiene false
 local notation:65 Γ " ⊢ " e1 " ≡ₚ " e2:30 => NormalEq Γ e1 e2
 
+/-- Residual conversion generated by a registered structure family.
+
+The two seed constructors retain the *actual* left- or right-reconstruction
+shape.  Their two equality payloads relate the majors and the complete
+constructor spines (hence every retained parameter and generated projector
+occurrence) at one descriptor.  The final two premises compose ordinary
+conversion around that seed without forgetting it; unlike the former broad
+base case, the reconstruction witness remains part of every `StructEq`.
+`forallE` is the pointwise closure needed when structure eta appears beneath
+ordinary function eta. -/
+inductive StructEq : List VExpr → VExpr → VExpr → Prop where
+  | etaL :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF univs) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    SpineWF env univs Γ (rule.familyType.instL levels) params
+      (.sort resultLevel) →
+    Γ ⊢ major₁ : rule.structureType levels params →
+    Γ ⊢ major₂ : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₁ :
+      rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₂ :
+      rule.structureType levels params →
+    Γ ⊢ major₁ ≡ major₂ : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₁ ≡
+      rule.rebuild levels params major₂ : rule.structureType levels params →
+    Γ ⊢ e₁ ≡ rule.rebuild levels params major₁ :
+      rule.structureType levels params →
+    Γ ⊢ major₂ ≡ e₂ : rule.structureType levels params →
+    StructEq Γ e₁ e₂
+  | etaR :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF univs) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    SpineWF env univs Γ (rule.familyType.instL levels) params
+      (.sort resultLevel) →
+    Γ ⊢ major₁ : rule.structureType levels params →
+    Γ ⊢ major₂ : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₁ :
+      rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₂ :
+      rule.structureType levels params →
+    Γ ⊢ major₁ ≡ major₂ : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₁ ≡
+      rule.rebuild levels params major₂ : rule.structureType levels params →
+    Γ ⊢ e₁ ≡ major₁ : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major₂ ≡ e₂ :
+      rule.structureType levels params →
+    StructEq Γ e₁ e₂
+  | forallE :
+    Γ ⊢ f : .forallE A B →
+    Γ ⊢ g : .forallE A B' →
+    StructEq (A::Γ) (.app f.lift (.bvar 0)) (.app g.lift (.bvar 0)) →
+    StructEq Γ f g
+
 inductive NormalEq : List VExpr → VExpr → VExpr → Prop where
   | refl : Γ ⊢ e : A → Γ ⊢ e ≡ₚ e
   | sortDF : l₁.WF univs → l₂.WF univs → l₁ ≈ l₂ → Γ ⊢ .sort l₁ ≡ₚ .sort l₂
@@ -109,10 +212,221 @@ inductive NormalEq : List VExpr → VExpr → VExpr → Prop where
     Γ ⊢ e' : .forallE A B →
     A::Γ ⊢ .app e'.lift (.bvar 0) ≡ₚ e →
     Γ ⊢ e' ≡ₚ .lam A e
+  | structural : StructEq Γ e₁ e₂ → Γ ⊢ e₁ ≡ₚ e₂
   | proofIrrel :
     Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p →
     Γ ⊢ h ≡ₚ h'
 
+variable! (hΓ : OnCtx Γ (env.IsType univs)) in
+theorem StructEq.defeq (H : StructEq Γ e₁ e₂) : Γ ⊢ e₁ ≡ e₂ := by
+  induction H with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      _ hmajor₂ _ hrebuild₂ _ hrebuildEq hleft hright =>
+    exact ⟨_, .trans hleft <| .trans hrebuildEq <| .trans
+      (.structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+        hmajor₂ hrebuild₂) hright⟩
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ _ hrebuild₁ _ _ hrebuildEq hleft hright =>
+    exact ⟨_, .trans hleft <| .trans (.symm <|
+      .structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+        hmajor₁ hrebuild₁) <| .trans hrebuildEq hright⟩
+  | forallE hf hg _ ih =>
+    have ⟨_, AB⟩ := hf.isType henv hΓ
+    have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv
+    have hΓ' : OnCtx (_ :: _) (env.IsType univs) :=
+      ⟨hΓ, ⟨_, hA.hasType.1⟩⟩
+    have ⟨_, he⟩ := ih hΓ'
+    have hleft := IsDefEqU.symm ⟨_, .eta hf⟩
+    have hmid := IsDefEq.lamDF hA he
+    exact ⟨_, .transU_r henv hΓ hleft <| hmid.transU_l henv hΓ ⟨_, .eta hg⟩⟩
+
+variable! (hΓ : OnCtx Γ (env.IsType univs)) in
+theorem StructEq.not_sort_r (hu : u.WF univs) : ¬StructEq Γ e (.sort u)
+  | .etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright
+  | .etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright =>
+    structEta_sort_disjoint hreg hlevels hlevelsLength hparamsLength
+      (hright.hasType.2.uniqU henv hΓ (HasType.sort hu))
+  | .forallE _ hg _ =>
+    ((HasType.sort hu).uniqU henv hΓ hg).sort_forallE_inv henv hΓ
+
+variable! (hΓ : OnCtx Γ (env.IsType univs)) in
+theorem StructEq.not_forallE_r
+    (hAB : Γ ⊢ .forallE A B : .sort u) : ¬StructEq Γ e (.forallE A B)
+  | .etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright
+  | .etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright =>
+    structEta_sort_disjoint hreg hlevels hlevelsLength hparamsLength
+      (hright.hasType.2.uniqU henv hΓ hAB)
+  | .forallE _ hg _ =>
+    (hAB.uniqU henv hΓ hg).sort_forallE_inv henv hΓ
+
+variable! (hΓ : OnCtx Γ (env.IsType univs)) in
+theorem StructEq.symm (H : StructEq Γ e₁ e₂) : StructEq Γ e₂ e₁ := by
+  induction H with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₂ hmajor₁ hrebuild₂ hrebuild₁ hmajorEq.symm
+        hrebuildEq.symm hright.symm hleft.symm
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₂ hmajor₁ hrebuild₂ hrebuild₁ hmajorEq.symm
+        hrebuildEq.symm hright.symm hleft.symm
+  | forallE hf hg _ ih =>
+    have ⟨_, AB⟩ := hf.isType henv hΓ
+    exact .forallE hg hf (ih ⟨hΓ, (AB.forallE_inv henv).1⟩)
+
+theorem StructEq.weakN (W : Ctx.LiftN n k Γ Γ')
+    (H : StructEq Γ e₁ e₂) :
+    StructEq Γ' (e₁.liftN n k) (e₂.liftN n k) := by
+  induction H generalizing k Γ' with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    have hparamsSpine := hparamsSpine.weakN henv W
+    rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.liftN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor₁ := hmajor₁.weakN henv W
+    have hmajor₂ := hmajor₂.weakN henv W
+    have hrebuild₁ := hrebuild₁.weakN henv W
+    have hrebuild₂ := hrebuild₂.weakN henv W
+    have hmajorEq := hmajorEq.weakN henv W
+    have hrebuildEq := hrebuildEq.weakN henv W
+    have hleft := hleft.weakN henv W
+    have hright := hright.weakN henv W
+    simp only [VStructEta.structureType_liftN] at hmajor₁ hmajor₂ hmajorEq hright
+    simp only [VStructEta.rebuild_liftN _ _ _ _ hparamsLength,
+      VStructEta.structureType_liftN] at hrebuild₁ hrebuild₂ hrebuildEq hleft
+    exact .etaL hreg hlevels hlevelsLength (by simpa using hparamsLength)
+      hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq
+        hrebuildEq hleft hright
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    have hparamsSpine := hparamsSpine.weakN henv W
+    rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.liftN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor₁ := hmajor₁.weakN henv W
+    have hmajor₂ := hmajor₂.weakN henv W
+    have hrebuild₁ := hrebuild₁.weakN henv W
+    have hrebuild₂ := hrebuild₂.weakN henv W
+    have hmajorEq := hmajorEq.weakN henv W
+    have hrebuildEq := hrebuildEq.weakN henv W
+    have hleft := hleft.weakN henv W
+    have hright := hright.weakN henv W
+    simp only [VStructEta.structureType_liftN] at hmajor₁ hmajor₂ hmajorEq hleft
+    simp only [VStructEta.rebuild_liftN _ _ _ _ hparamsLength,
+      VStructEta.structureType_liftN] at hrebuild₁ hrebuild₂ hrebuildEq hright
+    exact .etaR hreg hlevels hlevelsLength (by simpa using hparamsLength)
+      hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq
+        hrebuildEq hleft hright
+  | forallE hf hg _ ih =>
+    refine .forallE (hf.weakN henv W) (hg.weakN henv W) ?_
+    simpa [liftN, lift_liftN'] using ih W.succ
+
+variable! (h₀ : Γ₀ ⊢ e₀ : A₀) in
+theorem StructEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (H : StructEq Γ₁ e₁ e₂) :
+    StructEq Γ (e₁.inst e₀ k) (e₂.inst e₀ k) := by
+  induction H generalizing Γ k with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    have hparamsSpine := hparamsSpine.instN henv W h₀
+    rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.instN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor₁ := hmajor₁.instN henv W h₀
+    have hmajor₂ := hmajor₂.instN henv W h₀
+    have hrebuild₁ := hrebuild₁.instN henv W h₀
+    have hrebuild₂ := hrebuild₂.instN henv W h₀
+    have hmajorEq := hmajorEq.instN henv h₀ W
+    have hrebuildEq := hrebuildEq.instN henv h₀ W
+    have hleft := hleft.instN henv h₀ W
+    have hright := hright.instN henv h₀ W
+    simp only [VStructEta.structureType_instN] at hmajor₁ hmajor₂ hmajorEq hright
+    simp only [VStructEta.rebuild_instN _ _ _ _ _ hparamsLength,
+      VStructEta.structureType_instN] at hrebuild₁ hrebuild₂ hrebuildEq hleft
+    exact .etaL hreg hlevels hlevelsLength (by simpa using hparamsLength)
+      hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq
+        hrebuildEq hleft hright
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    have hparamsSpine := hparamsSpine.instN henv W h₀
+    rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.instN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor₁ := hmajor₁.instN henv W h₀
+    have hmajor₂ := hmajor₂.instN henv W h₀
+    have hrebuild₁ := hrebuild₁.instN henv W h₀
+    have hrebuild₂ := hrebuild₂.instN henv W h₀
+    have hmajorEq := hmajorEq.instN henv h₀ W
+    have hrebuildEq := hrebuildEq.instN henv h₀ W
+    have hleft := hleft.instN henv h₀ W
+    have hright := hright.instN henv h₀ W
+    simp only [VStructEta.structureType_instN] at hmajor₁ hmajor₂ hmajorEq hleft
+    simp only [VStructEta.rebuild_instN _ _ _ _ _ hparamsLength,
+      VStructEta.structureType_instN] at hrebuild₁ hrebuild₂ hrebuildEq hright
+    exact .etaR hreg hlevels hlevelsLength (by simpa using hparamsLength)
+      hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq
+        hrebuildEq hleft hright
+  | forallE hf hg _ ih =>
+    refine .forallE (hf.instN henv W h₀) (hg.instN henv W h₀) ?_
+    simpa [inst, lift_instN_lo] using ih W.succ
+
+variable! (hΓ : OnCtx Γ (env.IsType univs)) in
+theorem StructEq.app (H : StructEq Γ f g)
+    (hf : Γ ⊢ f : .forallE A B) (ha : Γ ⊢ a : A) :
+    StructEq Γ (.app f a) (.app g a) := by
+  cases H with
+  | etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ hleft _ =>
+    exact (structEta_forallE_disjoint hreg hlevels hlevelsLength
+      hparamsLength (hleft.hasType.1.uniqU henv hΓ hf)).elim
+  | etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ hleft _ =>
+    exact (structEta_forallE_disjoint hreg hlevels hlevelsLength
+      hparamsLength (hleft.hasType.1.uniqU henv hΓ hf)).elim
+  | forallE hf' hg' h =>
+    have ⟨⟨_, hA⟩, _⟩ := (hf.uniqU henv hΓ hf').forallE_inv henv hΓ
+    simpa [inst, inst_lift, instN_bvar0] using
+      h.instN (hA.defeq ha) .zero
+
+private theorem SpineWF.defeqDFC_early
+    (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) :
+    ∀ {A es B}, SpineWF env univs Γ₁ A es B →
+      SpineWF env univs Γ₂ A es B
+  | _, [], _, .nil => .nil
+  | _, _ :: _, _, .cons he hrest =>
+    .cons (he.defeqDFC henv W) (SpineWF.defeqDFC_early W hrest)
+
+variable! (H₀ : OnCtx Γ₀ (IsType env univs)) in
+theorem StructEq.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
+    (H : StructEq Γ₁ e₁ e₂) : StructEq Γ₂ e₁ e₂ := by
+  induction H generalizing Γ₂ with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaL hreg hlevels hlevelsLength hparamsLength
+      (hparamsSpine.defeqDFC_early W)
+      (.defeqDFC henv W hmajor₁) (.defeqDFC henv W hmajor₂)
+      (.defeqDFC henv W hrebuild₁) (.defeqDFC henv W hrebuild₂)
+      (.defeqDFC henv W hmajorEq) (.defeqDFC henv W hrebuildEq)
+      (.defeqDFC henv W hleft) (.defeqDFC henv W hright)
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaR hreg hlevels hlevelsLength hparamsLength
+      (hparamsSpine.defeqDFC_early W)
+      (.defeqDFC henv W hmajor₁) (.defeqDFC henv W hmajor₂)
+      (.defeqDFC henv W hrebuild₁) (.defeqDFC henv W hrebuild₂)
+      (.defeqDFC henv W hmajorEq) (.defeqDFC henv W hrebuildEq)
+      (.defeqDFC henv W hleft) (.defeqDFC henv W hright)
+  | forallE hf hg _ ih =>
+    have ⟨⟨_, hA⟩, _⟩ :=
+      let ⟨_, h⟩ := hf.isType henv (W.isType' H₀); h.forallE_inv henv
+    exact .forallE (.defeqDFC henv W hf) (.defeqDFC henv W hg)
+      (ih (W.succ hA))
+
 variable! (hΓ : OnCtx Γ (env.IsType univs)) in
 theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e1 ≡ e2 := by
   induction H with
@@ -138,6 +452,7 @@ theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e1 ≡ e2 := by
     have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv
     refine have hΓ' := ⟨hΓ, _, hA.hasType.1⟩; have ⟨_, he⟩ := ih hΓ'; ?_
     exact ⟨_, .transU_l henv hΓ (.symm (.eta h1)) ⟨_, .lamDF hA he⟩⟩
+  | structural h => exact h.defeq hΓ
   | proofIrrel h1 h2 h3 => exact ⟨_, .proofIrrel h1 h2 h3⟩
 
 variable! (hΓ : OnCtx Γ (env.IsType univs)) in
@@ -159,6 +474,7 @@ theorem NormalEq.symm (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e2 ≡ₚ e1 := by
   | etaR h1 _ ih =>
     have ⟨_, AB⟩ := h1.isType henv hΓ
     exact .etaL h1 (ih ⟨hΓ, (AB.forallE_inv henv).1⟩)
+  | structural h => exact .structural (h.symm hΓ)
   | proofIrrel h1 h2 h3 => exact .proofIrrel h1 h3 h2
 
 theorem NormalEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≡ₚ e2) :
@@ -182,6 +498,7 @@ theorem NormalEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≡ₚ e2) :
     refine .etaR (h1.weakN henv W) ?_
     have := ih W.succ
     simp [liftN] at this; rwa [lift_liftN']
+  | structural h => exact .structural (h.weakN W)
   | proofIrrel h1 h2 h3 =>
     exact .proofIrrel (h1.weakN henv W) (h2.weakN henv W) (h3.weakN henv W)
 
@@ -204,6 +521,7 @@ theorem NormalEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : Γ₁ ⊢
   | etaR h1 _ ih =>
     refine .etaR (h1.instN henv W h₀) ?_
     simpa [inst, lift_instN_lo] using ih W.succ
+  | structural h => exact .structural (h.instN h₀ W)
   | proofIrrel h1 h2 h3 => exact .proofIrrel (h1.instN henv W h₀) (h2.instN henv W h₀) (h3.instN henv W h₀)
 
 variable! (hΓ₁ : OnCtx Γ₁ (env.IsType univs)) (h₀ : Γ₀ ⊢ e₀ : A₀) (H' : Γ₀ ⊢ e₀ ≡ₚ e₀') in
@@ -265,6 +583,7 @@ theorem NormalEq.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
   | etaR h1 _ ih =>
     have ⟨⟨_, h2⟩, _⟩ := let ⟨_, h⟩ := h1.isType henv (W.isType' H₀); h.forallE_inv henv
     refine .etaR (.defeqDFC henv W h1) (ih (W.succ h2))
+  | structural h => exact .structural (h.defeqDFC H₀ W)
   | proofIrrel h1 h2 h3 =>
     exact .proofIrrel (.defeqDFC henv W h1)
       (.defeqDFC henv W h2) (.defeqDFC henv W h3)
@@ -273,6 +592,116 @@ variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem NormalEq.defeq_l (W : Γ ⊢ A ≡ A' : sort u) (H : A::Γ ⊢ e1 ≡ₚ e2) :
     A'::Γ ⊢ e1 ≡ₚ e2 := defeqDFC hΓ (.succ .zero W) H
 
+private theorem hasType_app_bvar0_early
+    (hΓ : OnCtx (A::Γ) (IsType env univs))
+    (H : A :: Γ ⊢ e.lift.app (bvar 0) : B) :
+    ∃ B', Γ ⊢ e : .forallE A B' := by
+  have ⟨_, _, c1, c2⟩ := H.app_inv henv hΓ
+  replace c1 :=
+    have ⟨_, d1⟩ := c1.isType henv hΓ
+    have ⟨_, _, d3⟩ := d1.forallE_inv henv
+    have ⟨_, d4⟩ := c2.uniq henv hΓ (.bvar .zero)
+    HasType.defeqU_r henv hΓ ⟨_, d4.forallEDF d3⟩ c1
+  have heta := c1.eta
+  rw [show A.lift.lam (e.lift.lift.app (bvar 0)) =
+      (A.lam (e.lift.app (bvar 0))).lift by
+    simp [VExpr.liftN, liftN'_liftN_lo, liftN_liftN]] at heta
+  have ⟨_, f1⟩ := (IsDefEqU.weakN_iff henv hΓ .one).1 ⟨_, heta⟩
+  have ⟨⟨_, f2⟩, _, f3⟩ := f1.hasType.1.lam_inv henv hΓ.1
+  exact ⟨_, (HasType.lam f2 f3).defeqU_l henv hΓ.1 ⟨_, f1⟩⟩
+
+variable! (hΓ₀ : OnCtx Γ₀ (IsType env univs)) in
+theorem StructEq.weakN_inv_DFC
+    (W : Ctx.LiftN n k Γ Γ₂)
+    (W₂ : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
+    (H : StructEq Γ₁ (e₁.liftN n k) (e₂.liftN n k)) :
+    StructEq Γ e₁ e₂ := by
+  generalize eq0 : Γ₁ = Γ₁' at H
+  generalize eq1 : e₁.liftN n k = e₁' at H
+  generalize eq2 : e₂.liftN n k = e₂' at H
+  revert W₂
+  induction H generalizing Γ Γ₁ Γ₂ e₁ e₂ k with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    intro W₂
+    subst eq1
+    subst eq2
+    subst_vars
+    have hΓ₁ := W₂.isType' hΓ₀
+    have hΓ₂ := (W₂.symm henv).isType' hΓ₀
+    have hseed : Γ₁ ⊢ e₁.liftN n k ≡ e₂.liftN n k :
+        _ := .trans hleft <| .trans hrebuildEq <| .trans
+      (.structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+        hmajor₂ hrebuild₂) hright
+    obtain ⟨levels', params', resultLevel', hlevelsLength', hparamsLength',
+        hlevels', hparamsSpine', h'⟩ :=
+      structEta_weakN_inv hreg hlevels hlevelsLength hparamsLength hΓ₂ W
+        (hseed.defeqDFC henv W₂)
+    have hΓ := hΓ₂.weakN_inv henv W
+    have hmajor := h'.hasType.2
+    have hrebuild := (henv.ordered.structEtaWF hreg).rebuild_hasType
+      VEnv.LE.rfl hΓ hlevels' hlevelsLength' hparamsLength'
+        ⟨resultLevel', hparamsSpine'⟩ hmajor
+    have heta := IsDefEq.structEta hreg hlevels' hlevelsLength'
+      hparamsLength' hparamsSpine' hmajor hrebuild
+    exact .etaL hreg hlevels' hlevelsLength' hparamsLength' hparamsSpine'
+      hmajor hmajor hrebuild hrebuild hmajor hrebuild
+        (.trans h' heta.symm) hmajor
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    intro W₂
+    subst eq1
+    subst eq2
+    subst_vars
+    have hΓ₁ := W₂.isType' hΓ₀
+    have hΓ₂ := (W₂.symm henv).isType' hΓ₀
+    have hseed : Γ₁ ⊢ e₁.liftN n k ≡ e₂.liftN n k :
+        _ := .trans hleft <| .trans (.symm <|
+      .structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+        hmajor₁ hrebuild₁) <| .trans hrebuildEq hright
+    obtain ⟨levels', params', resultLevel', hlevelsLength', hparamsLength',
+        hlevels', hparamsSpine', h'⟩ :=
+      structEta_weakN_inv hreg hlevels hlevelsLength hparamsLength hΓ₂ W
+        (hseed.defeqDFC henv W₂)
+    have hΓ := hΓ₂.weakN_inv henv W
+    have hmajor := h'.hasType.2
+    have hrebuild := (henv.ordered.structEtaWF hreg).rebuild_hasType
+      VEnv.LE.rfl hΓ hlevels' hlevelsLength' hparamsLength'
+        ⟨resultLevel', hparamsSpine'⟩ hmajor
+    have heta := IsDefEq.structEta hreg hlevels' hlevelsLength'
+      hparamsLength' hparamsSpine' hmajor hrebuild
+    exact .etaL hreg hlevels' hlevelsLength' hparamsLength' hparamsSpine'
+      hmajor hmajor hrebuild hrebuild hmajor hrebuild
+        (.trans h' heta.symm) hmajor
+  | forallE hf hg _ ih =>
+    intro W₂
+    subst eq1
+    subst eq2
+    subst_vars
+    have hΓ₁ := W₂.isType' hΓ₀
+    have ⟨⟨_, hA⟩, _, _⟩ :=
+      let ⟨_, h⟩ := hf.isType henv hΓ₁; h.forallE_inv henv
+    have hf' := hf.defeqDFC henv W₂
+    have hΓ₂ := (W₂.symm henv).isType' hΓ₀
+    obtain ⟨A₀, B₀, hf₀⟩ := forallE_weakN_inv hΓ₂ W hf'
+    have ⟨⟨_, hAeq⟩, _⟩ :=
+      (hf'.uniqU henv hΓ₂ (hf₀.weakN henv W)).forallE_inv henv hΓ₂
+    have hAeq' := hAeq.defeqDFC henv (W₂.symm henv)
+    have hbody := ih (e₁ := e₁.lift.app (.bvar 0))
+      (e₂ := e₂.lift.app (.bvar 0)) W.succ rfl
+      (by simp [liftN, lift_liftN']) (by simp [liftN, lift_liftN'])
+      (W₂.succ hAeq')
+    have hΓ := hΓ₂.weakN_inv henv W
+    have ⟨_, hfunType⟩ := hf₀.isType henv hΓ
+    have ⟨⟨_, hA₀⟩, _⟩ := hfunType.forallE_inv henv
+    have hΓ' : OnCtx (_ :: Γ) (env.IsType univs) :=
+      ⟨hΓ, ⟨_, hA₀.hasType.1⟩⟩
+    obtain ⟨_, hg₀⟩ := hasType_app_bvar0_early hΓ'
+      (hbody.defeq hΓ').choose_spec.hasType.2
+    exact .forallE hf₀ hg₀ hbody
+
 variable! (hΓ₀ : OnCtx Γ₀ (IsType env univs)) in
 theorem NormalEq.weakN_inv_DFC (W : Ctx.LiftN n k Γ Γ₂) (W₂ : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
     (H : Γ₁ ⊢ e1.liftN n k ≡ₚ e2.liftN n k) : Γ ⊢ e1 ≡ₚ e2 := by
@@ -365,6 +794,10 @@ theorem NormalEq.weakN_inv_DFC (W : Ctx.LiftN n k Γ Γ₂) (W₂ : IsDefEqCtx e
     have := (IsDefEq.weakN_iff (A := .forallE ..) henv hΓ₂'.1 W).1 <|
       IsDefEq.defeq (.forallEDF hA' hu) h1'
     refine .etaR this (ih W.succ (W₂.succ hA) (by simp [liftN, lift_liftN']) rfl)
+  | structural h =>
+    subst eq1
+    subst eq2
+    exact .structural (h.weakN_inv_DFC hΓ₀ W W₂)
   | proofIrrel h1 h2 h3 =>
     subst eq1; subst eq2
     have h1' := h1.defeqDFC henv W₂
@@ -393,6 +826,36 @@ omit [Params] in private theorem meas_liftN : meas (e.liftN n k) = meas e := by
   induction e generalizing k <;> simp [*, meas, liftN]
 omit [Params] in private theorem meas_lift : meas e.lift = meas e := meas_liftN
 
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem StructEq.trans_right (H : StructEq Γ e₁ e₂)
+    (h : Γ ⊢ e₂ ≡ e₃) : StructEq Γ e₁ e₃ := by
+  induction H generalizing e₃ with
+  | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+        hleft (hright.transU_l henv hΓ h)
+  | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+      hleft hright =>
+    exact .etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq
+        hleft (hright.transU_l henv hΓ h)
+  | forallE hf hg _ ih =>
+    have ⟨_, AB⟩ := hf.isType henv hΓ
+    have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv
+    have hΓ' : OnCtx (_ :: _) (env.IsType univs) :=
+      ⟨hΓ, ⟨_, hA.hasType.1⟩⟩
+    have hfun := h.of_l henv hΓ hg
+    have happ := IsDefEq.appDF (hfun.weakN henv .one) (.bvar .zero)
+    exact .forallE hf hfun.hasType.2 (ih hΓ' ⟨_, happ⟩)
+
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem StructEq.trans_left (h : Γ ⊢ e₀ ≡ e₁)
+    (H : StructEq Γ e₁ e₂) : StructEq Γ e₀ e₂ :=
+  ((H.symm hΓ).trans_right hΓ h.symm).symm hΓ
+
 attribute [local simp] meas meas_lift in
 theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) :
     Γ ⊢ e1 ≡ₚ e2 → Γ ⊢ e2 ≡ₚ e3 → Γ ⊢ e1 ≡ₚ e3
@@ -431,6 +894,14 @@ theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) :
       have hw := let ⟨_, h⟩ := hA.isType henv hΓ; h.sort_inv henv
       exact ⟨_, .sortDF ⟨hw, ⟨⟩⟩ ⟨⟩ rfl⟩
     | appDF _ _ _ _ ih => exact (NormalEq.weakN_iff (by exact ⟨hΓ, _, hA⟩) .one).1 ih
+    | structural hs =>
+      have hΓ' : OnCtx (_ :: _) (env.IsType univs) :=
+        ⟨hΓ, ⟨_, hA.hasType.1⟩⟩
+      have ⟨_, hse⟩ := hs.defeq hΓ'
+      obtain ⟨_, hr⟩ := hasType_app_bvar0_early hΓ' hse.hasType.2
+      exact .structural (.forallE l1 hr hs)
+  | .structural hs, H2 => by
+    exact .structural (hs.trans_right hΓ (H2.defeq hΓ))
   | .refl h, H2 => H2
   | .proofIrrel l1 l2 l3, H2 => .proofIrrel l1 l2 (.defeqU_l henv hΓ (H2.defeq hΓ) l3)
   | .etaL l1 ih, H2 => by
@@ -446,6 +917,8 @@ theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) :
     refine .appDF ((r1.defeqU_l henv hΓ (H1.defeq hΓ).symm).weakN henv .one)
       (r1.weakN henv .one) (.bvar .zero) (.bvar .zero)
       (.weakN .one H1) (.refl (.bvar .zero))
+  | H1, .structural hs => by
+    exact .structural (hs.trans_left hΓ (H1.defeq hΓ))
   | H1, .proofIrrel h1 h2 h3 => .proofIrrel h1 (.defeqU_l henv hΓ (H1.defeq hΓ).symm h2) h3
 termination_by meas e1 + meas e2 + meas e3
 
@@ -463,6 +936,108 @@ theorem NormalEq.apply_pat
       h2 (.defeqU_l henv hΓ ((ih2 h2).defeq hΓ) h2) (ih1 h1) (ih2 h2)
   | var path => exact ih path _ he
 
+/-!
+### Level congruence
+
+A registered contraction fires at whatever universe arguments the redex
+carries. When two `NormalEq`-related redexes differ only in `≈`-equivalent
+level arguments, the two contracta differ only in those same levels, so the
+pattern side conditions transport and the contracta are again `NormalEq`.
+`EqUpToLevels` (`Theory/Typing/Strong.lean`) is exactly that relation; what
+is added here is its purely syntactic instantiation law, its symmetry, its
+`Pattern.RHS.apply` congruence, and the bridge back into `NormalEq`.
+-/
+
+omit [Params] in
+theorem EqUpToLevels.symm' {U} {e e' : VExpr} (H : EqUpToLevels U e e') :
+    EqUpToLevels U e' e := by
+  induction H with
+  | bvar => exact .bvar
+  | const h1 h2 h3 => exact .const h2 h1 (h3.flip.imp fun _ _ h => h.symm)
+  | sort h1 h2 h3 => exact .sort h2 h1 h3.symm
+  | app _ _ ih1 ih2 => exact .app ih1 ih2
+  | lam _ _ ih1 ih2 => exact .lam ih1 ih2
+  | forallE _ _ ih1 ih2 => exact .forallE ih1 ih2
+
+/-!
+Instantiating *any* expression at two pointwise-equivalent well-formed level
+lists gives `EqUpToLevels`.  Unlike `EqUpToLevels.instL` this needs no
+derivation for the expression: it is pure syntax, which is what makes it
+usable on the closed templates sitting inside a `Pattern.RHS`.
+-/
+omit [Params] in
+theorem EqUpToLevels.instL_equiv {U} {ls ls' : List VLevel}
+    (hls : ∀ l ∈ ls, l.WF U) (hls' : ∀ l ∈ ls', l.WF U)
+    (heq : List.Forall₂ (· ≈ ·) ls ls') :
+    ∀ e : VExpr, EqUpToLevels U (e.instL ls) (e.instL ls')
+  | .bvar _ => .bvar
+  | .sort _ => .sort (.inst hls) (.inst hls') (VLevel.inst_congr rfl heq)
+  | .const _ _ => .const
+      (List.forall_mem_map.2 fun _ _ => .inst hls)
+      (List.forall_mem_map.2 fun _ _ => .inst hls')
+      (List.forall₂_map_left_iff.2 <| List.forall₂_map_right_iff.2 <|
+        .rfl fun _ _ => VLevel.inst_congr rfl heq)
+  | .app .. => .app (instL_equiv hls hls' heq _) (instL_equiv hls hls' heq _)
+  | .lam .. => .lam (instL_equiv hls hls' heq _) (instL_equiv hls hls' heq _)
+  | .forallE .. => .forallE (instL_equiv hls hls' heq _) (instL_equiv hls hls' heq _)
+
+omit [Params] in
+theorem EqUpToLevels.apply_instL {U} {p : Pattern} {ls ls' : List VLevel}
+    {m2 : p.Path → VExpr} (r : p.RHS)
+    (hls : ∀ l ∈ ls, l.WF U) (hls' : ∀ l ∈ ls', l.WF U)
+    (heq : List.Forall₂ (· ≈ ·) ls ls')
+    (hm : ∀ x, EqUpToLevels U (m2 x) (m2 x)) :
+    EqUpToLevels U (r.apply ls m2) (r.apply ls' m2) := by
+  induction r with
+  | fixed c _ => exact EqUpToLevels.instL_equiv hls hls' heq c
+  | app f a ih1 ih2 => exact .app ih1 ih2
+  | var x => exact hm x
+
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem EqUpToLevels.normalEq (H : EqUpToLevels univs e1 e2)
+    {A} (he : Γ ⊢ e1 : A) : Γ ⊢ e1 ≡ₚ e2 := by
+  induction H generalizing Γ A with
+  | bvar => exact .refl he
+  | const h1 h2 h3 =>
+    have ⟨_, c1, _, c3⟩ := he.const_inv henv hΓ
+    exact .constDF c1 h1 h2 c3 h3
+  | sort h1 h2 h3 => exact .sortDF h1 h2 h3
+  | app _ _ ih1 ih2 =>
+    have ⟨_, _, hf, ha⟩ := he.app_inv henv hΓ
+    have n1 := ih1 hΓ hf
+    have n2 := ih2 hΓ ha
+    exact .appDF hf (.defeqU_l henv hΓ (n1.defeq hΓ) hf)
+      ha (.defeqU_l henv hΓ (n2.defeq hΓ) ha) n1 n2
+  | lam _ _ ih1 ih2 =>
+    have ⟨⟨_, hA⟩, _, hb⟩ := he.lam_inv henv hΓ
+    exact .lamDF hA (((ih1 hΓ hA).defeq hΓ).of_l henv hΓ hA)
+      (ih2 (by exact ⟨hΓ, _, hA⟩) hb)
+  | forallE _ _ ih1 ih2 =>
+    have ⟨⟨_, hA⟩, _, hB⟩ := he.forallE_inv henv
+    exact .forallEDF hA (ih1 hΓ hA) hB (ih2 (by exact ⟨hΓ, _, hA⟩) hB)
+
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem EqUpToLevels.normalEq_r (H : EqUpToLevels univs e1 e2)
+    {A} (he : Γ ⊢ e2 : A) : Γ ⊢ e1 ≡ₚ e2 := (H.symm'.normalEq hΓ he).symm hΓ
+
+/-! The pattern side conditions transport along `≈`-equivalent level lists. -/
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem _root_.Lean4Lean.Pattern.Check.OK.instL_equiv
+    {p : Pattern} (ck : p.Check) {ls ls' : List VLevel} {m2 : p.Path → VExpr}
+    (hls : ∀ l ∈ ls, l.WF univs) (hls' : ∀ l ∈ ls', l.WF univs)
+    (heq : List.Forall₂ (· ≈ ·) ls ls')
+    (hm : ∀ x, EqUpToLevels univs (m2 x) (m2 x))
+    (H : ck.OK (IsDefEqU env univs Γ) ls' m2) :
+    ck.OK (IsDefEqU env univs Γ) ls m2 := by
+  have heq' : List.Forall₂ (· ≈ ·) ls' ls := heq.flip.imp fun _ _ h => h.symm
+  refine H.map (fun a b h => ?_)
+  obtain ⟨T, hT⟩ := h
+  have ea := IsDefEq.eqUpToLevels henv hΓ hT.hasType.1
+    (EqUpToLevels.apply_instL a hls' hls heq' hm)
+  have eb := IsDefEq.eqUpToLevels henv hΓ hT.hasType.2
+    (EqUpToLevels.apply_instL b hls' hls heq' hm)
+  exact ⟨T, (ea.symm.trans hT).trans eb⟩
+
 set_option hygiene false
 local notation:65 Γ " ⊢ " e1 " ≫ " e2:36 => ParRed Γ e1 e2
 local notation:65 Γ " ⊢ " e1 " ⋙ " e2:36 => CParRed Γ e1 e2
@@ -475,12 +1050,18 @@ inductive ParRed : List VExpr → VExpr → VExpr → Prop where
   | lam : Γ ⊢ A ≫ A' → A::Γ ⊢ body ≫ body' → Γ ⊢ .lam A body ≫ .lam A' body'
   | forallE : Γ ⊢ A ≫ A' → A::Γ ⊢ B ≫ B' → Γ ⊢ .forallE A B ≫ .forallE A' B'
   | beta : A::Γ ⊢ e₁ ≫ e₁' → Γ ⊢ e₂ ≫ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ≫ e₁'.inst e₂'
+  /-- A consumer-certified pattern contraction.  The equality certificate is
+  carried by the step itself: membership in `Pat` and a successful match do
+  not make an external equation trusted. -/
   | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 →
+    IsDefEqU env univs Γ e (r.1.apply m1 m2) →
     (∀ a, Γ ⊢ m2 a ≫ m2' a) → Γ ⊢ e ≫ r.1.apply m1 m2'
 
 def NonNeutral (Γ : List VExpr) (e : VExpr) : Prop :=
   (∃ A e₁ e₂, e = .app (.lam A e₁) e₂) ∨
-  (∃ p r m1 m2, Pat p r ∧ p.Matches e m1 m2 ∧ r.2.OK (IsDefEqU env univs Γ) m1 m2)
+  (∃ p r m1 m2, Pat p r ∧ p.Matches e m1 m2 ∧
+    r.2.OK (IsDefEqU env univs Γ) m1 m2 ∧
+    IsDefEqU env univs Γ e (r.1.apply m1 m2))
 
 inductive CParRed : List VExpr → VExpr → VExpr → Prop where
   | bvar : Γ ⊢ .bvar i ⋙ .bvar i
@@ -491,6 +1072,7 @@ inductive CParRed : List VExpr → VExpr → VExpr → Prop where
   | forallE : Γ ⊢ A ⋙ A' → A::Γ ⊢ B ⋙ B' → Γ ⊢ .forallE A B ⋙ .forallE A' B'
   | beta : A::Γ ⊢ e₁ ⋙ e₁' → Γ ⊢ e₂ ⋙ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ⋙ e₁'.inst e₂'
   | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 →
+    IsDefEqU env univs Γ e (r.1.apply m1 m2) →
     (∀ a, Γ ⊢ m2 a ⋙ m2' a) → Γ ⊢ e ⋙ r.1.apply m1 m2'
 
 protected theorem ParRed.rfl : ∀ {e}, Γ ⊢ e ≫ e
@@ -511,10 +1093,12 @@ theorem ParRed.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≫ e2) :
   | beta _ _ ih1 ih2 =>
     simp [liftN, liftN_inst_hi]
     exact .beta (ih1 W.succ) (ih2 W)
-  | extra h1 h2 h3 _ ih =>
+  | extra h1 h2 h3 h4 _ ih =>
+    have h4 := h4.weakN henv W
+    rw [Pattern.RHS.liftN_apply] at h4
     rw [Pattern.RHS.liftN_apply]
     refine .extra h1 (Pattern.matches_liftN.2 ⟨_, h2, funext_iff.1 rfl⟩)
-      (h3.weakN W) (fun a => ih _ W)
+      (h3.weakN W) h4 (fun a => ih _ W)
 
 variable! (H₀ : Γ₀ ⊢ a1 ≫ a2) (H₀' : Γ₀ ⊢ a1 : A₀) in
 theorem ParRed.instN (W : Ctx.InstN Γ₀ a1 A₀ k Γ₁ Γ)
@@ -538,9 +1122,12 @@ theorem ParRed.instN (W : Ctx.InstN Γ₀ a1 A₀ k Γ₁ Γ)
   | beta _ _ ih1 ih2 =>
     simp [inst, inst0_inst_hi]
     exact .beta (ih1 W.succ) (ih2 W)
-  | extra h1 h2 h3 _ ih =>
+  | extra h1 h2 h3 h4 _ ih =>
+    have h4 := h4.instN henv W H₀'
+    rw [Pattern.RHS.instN_apply] at h4
     rw [Pattern.RHS.instN_apply]
-    exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀') (fun a => ih _ W)
+    exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀')
+      h4 (fun a => ih _ W)
 
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem ParRed.defeq (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e ≡ e' : A := by
@@ -564,9 +1151,10 @@ theorem ParRed.defeq (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e ≡ e'
     exact .trans_l henv hΓ he <| .trans
       (.symm <| .appDF (.symm <| .lamDF hA (ih1 ⟨hΓ, _, hA⟩ hb)) (.symm <| ih2 hΓ ha))
       (.beta (ih1 ⟨hΓ, _, hA⟩ hb).hasType.2 (ih2 hΓ ha).hasType.2)
-  | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih =>
-    exact .trans_l henv hΓ he <| .transU_r henv hΓ (pat_wf h1 h2 he h3) <|
-     .apply_pat hΓ (fun _ _ h => ⟨_, ih _ hΓ h⟩) (.defeqU_l henv hΓ (pat_wf h1 h2 he h3) he)
+  | @extra p r e m1 m2 Γ m2' h1 h2 h3 h4 _ ih =>
+    exact .trans_l henv hΓ he <| .transU_r henv hΓ h4 <|
+      .apply_pat hΓ (fun _ _ h => ⟨_, ih _ hΓ h⟩)
+        (.defeqU_l henv hΓ h4 he)
 
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem ParRed.hasType (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e' : A :=
@@ -592,9 +1180,11 @@ theorem ParRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
     have ⟨_, _, hf, ha⟩ := h.app_inv henv (W.isType' hΓ₀)
     have ⟨⟨_, hA⟩, _, hb⟩ := hf.lam_inv henv (W.isType' hΓ₀)
     exact .beta (ih1 (W.succ hA) hb) (ih2 W ha)
-  | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih =>
-    exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W) fun a =>
-      let ⟨_, h⟩ := h2.hasType (W.isType' hΓ₀) h a; ih a W h
+  | @extra p r e m1 m2 Γ m2' h1 h2 h3 h4 _ ih =>
+    exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W)
+      (h4.defeqDFC henv W) fun a =>
+        let ⟨_, h⟩ := h2.hasType (W.isType' hΓ₀) h a
+        ih a W h
 
 theorem ParRed.apply_pat {p : Pattern} (r : p.RHS) {m1 m2 m3}
     (H : ∀ a, Γ ⊢ m2 a ≫ m3 a) : Γ ⊢ r.apply m1 m2 ≫ r.apply m1 m3 := by
@@ -673,30 +1263,32 @@ theorem ParRed.weakN_inv (W : Ctx.LiftN n k Γ Γ')
     obtain ⟨_, a1, rfl⟩ := ih1 (by exact ⟨hΓ, _, hA⟩) W.succ hb rfl
     obtain ⟨_, b1, rfl⟩ := ih2 hΓ W ha rfl
     exact ⟨_, .beta a1 b1, (liftN_inst_hi ..).symm⟩
-  | @extra p r e m1 m2 Γ' m2' h1 h2 h3 h4 ih =>
+  | @extra p r e m1 m2 Γ' m2' h1 h2 h3 h4 h5 ih =>
     suffices ∃ m3 m3' : _ → _, p.Matches e1 m1 m3 ∧
         (∀ a, Γ ⊢ m3 a ≫ m3' a) ∧
         (∀ a, m2 a = (m3 a).liftN n k) ∧
         (∀ a, m2' a = (m3' a).liftN n k) by
       let ⟨m3, m3', a1, a2, a3, a4⟩ := this
-      refine ⟨_, .extra h1 a1 (h3.map fun _ _ h => ?_) a2,
+      refine ⟨_, .extra h1 a1 (h3.map fun _ _ h => ?_) ?_ a2,
         .trans (by congr; funext; apply a4) r.1.apply_liftN.symm⟩
       rw [(funext a3 : m2 = _), ← Pattern.RHS.apply_liftN, ← Pattern.RHS.apply_liftN] at h
       exact (IsDefEqU.weakN_iff henv hΓ W).1 h
-    clear h1 h3 r
+      rw [← eq, (funext a3 : m2 = _), ← Pattern.RHS.apply_liftN] at h4
+      exact (IsDefEqU.weakN_iff henv hΓ W).1 h4
+    clear h1 h3 h4 r
     induction h2 generalizing e1 A with
     | const => cases e1 <;> cases eq; exact ⟨_, nofun, .const, nofun, nofun, nofun⟩
     | var h1 ih1 =>
       cases e1 <;> cases eq
       have ⟨_, _, hf, ha⟩ := h.app_inv henv hΓ
-      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| some ·) (ih <| some ·) hf rfl
+      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h5 <| some ·) (ih <| some ·) hf rfl
       have ⟨_, b2, b4⟩ := ih none hΓ W ha rfl
       exact ⟨_, Option.rec _ _, .var a1, Option.rec b2 a2, Option.rec rfl a3, Option.rec b4 a4⟩
     | app h1 h2 ih1 ih2 =>
       cases e1 <;> cases eq
       have ⟨_, _, hf, ha⟩ := h.app_inv henv hΓ
-      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| .inl ·) (ih <| .inl ·) hf rfl
-      have ⟨_, _, b1, b2, b3, b4⟩ := ih2 (h4 <| .inr ·) (ih <| .inr ·) ha rfl
+      have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h5 <| .inl ·) (ih <| .inl ·) hf rfl
+      have ⟨_, _, b1, b2, b3, b4⟩ := ih2 (h5 <| .inr ·) (ih <| .inr ·) ha rfl
       exact ⟨_, Sum.rec _ _, .app a1 b1, Sum.rec a2 b2, Sum.rec a3 b3, Sum.rec a4 b4⟩
 
 theorem CParRed.toParRed (H : Γ ⊢ e ⋙ e') : Γ ⊢ e ≫ e' := by
@@ -708,7 +1300,7 @@ theorem CParRed.toParRed (H : Γ ⊢ e ⋙ e') : Γ ⊢ e ≫ e' := by
   | lam _ _ ih1 ih2 => exact .lam ih1 ih2
   | forallE _ _ ih1 ih2 => exact .forallE ih1 ih2
   | beta _ _ ih1 ih2 => exact .beta ih1 ih2
-  | extra h1 h2 h3 _ ih3 => exact .extra h1 h2 h3 ih3
+  | extra h1 h2 h3 h4 _ ih3 => exact .extra h1 h2 h3 h4 ih3
 
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem CParRed.exists (H : Γ ⊢ e : A) : ∃ e', Γ ⊢ e ⋙ e' := by
@@ -716,15 +1308,15 @@ theorem CParRed.exists (H : Γ ⊢ e : A) : ∃ e', Γ ⊢ e ⋙ e' := by
   revert e_ih; change let motive := ?_; ∀ _: e.below (motive := motive), _; intro motive e_ih
   have neut {e} (H' : Γ ⊢ e : A) (e_ih : e.below (motive := motive)) :
       NonNeutral Γ e → ∃ e', Γ ⊢ e ⋙ e' := by
-    rintro (⟨A, e, a, rfl⟩ | ⟨p, r, m1, m2, h1, hp2, hp3⟩)
+    rintro (⟨A, e, a, rfl⟩ | ⟨p, r, m1, m2, h1, hp2, hp3, hp4⟩)
     · have ⟨_, _, hf, ha⟩ := H'.app_inv henv hΓ
       have ⟨⟨_, hA⟩, _, he⟩ := hf.lam_inv henv hΓ
       have ⟨_, he⟩ := e_ih.1.2.2.1 (by exact ⟨hΓ, _, hA⟩) he
       have ⟨_, ha⟩ := e_ih.2.1 hΓ ha
       exact ⟨_, .beta he ha⟩
     · suffices ∃ m3 : p.Path → VExpr, ∀ a, Γ ⊢ m2 a ⋙ m3 a from
-        let ⟨_, h3⟩ := this; ⟨_, .extra h1 hp2 hp3 h3⟩
-      clear H r h1 hp3
+        let ⟨_, h3⟩ := this; ⟨_, .extra h1 hp2 hp3 hp4 h3⟩
+      clear H r h1 hp3 hp4
       induction p generalizing e m1 A with
       | const => exact ⟨nofun, nofun⟩
       | app f a ih1 ih2 =>
@@ -776,7 +1368,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e
   | const hn =>
     cases H with
     | const => exact ⟨_, .rfl, .refl H1⟩
-    | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩)
+    | extra h1 h2 h3 h4 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3, h4⟩)
   | app hn _ _ ih1 ih2 =>
     have ⟨_, _, l1, l2⟩ := H1.app_inv henv hΓ
     cases H with
@@ -785,7 +1377,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e
       have o1 := p1.hasType hΓ (r1.hasType hΓ l1); have o2 := p2.hasType hΓ (r2.hasType hΓ l2)
       exact ⟨_, .app p1 p2, .appDF o1 (.defeqU_l henv hΓ (n1.defeq hΓ) o1)
         o2 (.defeqU_l henv hΓ (n2.defeq hΓ) o2) n1 n2⟩
-    | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩)
+    | extra h1 h2 h3 h4 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3, h4⟩)
     | beta => cases hn (.inl ⟨_, _, _, rfl⟩)
   | lam _ _ ih1 ih2 =>
     have ⟨⟨_, l1⟩, _, l2⟩ := H1.lam_inv henv hΓ
@@ -835,14 +1427,14 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e
           (p2.hasType hΓ' (re.hasType hΓ' le)))
         (.instN (l2.toParRed.hasType hΓ la') .zero n2)
     | extra h1 h2 => cases h2 with | app h | var h => cases h
-  | @extra p r e m1 m2 Γ m2' l1 l2 l3 l4 ih =>
+  | @extra p r e m1 m2 Γ m2' l1 l2 l3 l4 l5 ih =>
     have :
       (∃ m3 m3' : p.Path → VExpr, p.Matches e' m1 m3 ∧
         (∀ a, Γ ⊢ m2 a ≫ m3 a) ∧ (∀ a, Γ ⊢ m3 a ≫ m3' a) ∧ (∀ a, Γ ⊢ m3' a ≡ₚ m2' a)) ∨
       (∃ p₁ e₁' e₁ m1₁ m2₁, Subpattern p₁ p ∧ (p₁ = p → e₁ = e ∧ e₁' = e' ∧ m1₁ ≍ m1 ∧ m2₁ ≍ m2) ∧
         p₁.Matches e₁ m1₁ m2₁ ∧ ∃ p' r m1 m2 m2',
         Pat p' r ∧ p'.Matches e₁ m1 m2 ∧ (∀ a, Γ ⊢ m2 a ≫ m2' a) ∧ e₁' = r.1.apply m1 m2') := by
-      clear l1 l3 l4 r
+      clear l1 l3 l4 l5 r
       induction H generalizing p m1 A with
       | const =>
         cases id l2; exact .inl ⟨_, _, l2, nofun, fun _ => .rfl, nofun⟩
@@ -872,18 +1464,28 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e
               exact .inl ⟨_, Sum.elim _ _, .app f1 a1,
                 (·.casesOn f2 a2), (·.casesOn f3 a3), (·.casesOn f4 a4)⟩
       | beta _ _ => cases l2 with | var h | app h => cases h
-      | @extra _ _ _ _ _ _ _ r1 r2 _ r4 =>
+      | @extra _ _ _ _ _ _ _ r1 r2 _ _ r4 =>
         exact .inr ⟨_, _, _, _, _, .refl, fun _ => ⟨rfl, rfl, .rfl, .rfl⟩,
           l2, _, _, _, _, _, r1, r2, r4, rfl⟩
       | _ => cases l2
     match this with
     | .inl ⟨m3, m3', h1, h2, h3, h4⟩ =>
-      refine
-        have h := .extra l1 h1 (l3.map fun _ _ ⟨_, h1⟩ => ?_) h3
-        ⟨_, h, .apply_pat hΓ (fun a _ _ => h4 a) (h.hasType hΓ (H.hasType hΓ H1))⟩
-      refine ⟨_, .trans
-        (.symm <| .apply_pat hΓ (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) h1.hasType.1)
-        (.trans h1 <| .apply_pat hΓ (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) h1.hasType.2)⟩
+      have hcheck : r.2.OK (IsDefEqU env univs Γ) m1 m3 :=
+        l3.map fun _ _ ⟨_, hc⟩ => by
+          refine ⟨_, .trans
+            (.symm <| .apply_pat hΓ
+              (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) hc.hasType.1)
+            (.trans hc <| .apply_pat hΓ
+              (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) hc.hasType.2)⟩
+      have he' : IsDefEqU env univs Γ e e' := ⟨_, H.defeq hΓ H1⟩
+      have hrhs : IsDefEqU env univs Γ (r.1.apply m1 m2) (r.1.apply m1 m3) :=
+        ⟨_, IsDefEq.apply_pat hΓ
+          (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) l4.choose_spec.hasType.2⟩
+      have hsound := IsDefEqU.trans henv hΓ he'.symm
+        (IsDefEqU.trans henv hΓ l4 hrhs)
+      have h : Γ ⊢ e' ≫ r.1.apply m1 m3' := .extra l1 h1 hcheck hsound h3
+      exact ⟨_, h, .apply_pat hΓ (fun a _ _ => h4 a)
+        (h.hasType hΓ (H.hasType hΓ H1))⟩
     | .inr ⟨_, _, _, _, _, h1, h2, l2', _, _, _, _, m3, r1, r2, r4, e⟩ =>
       obtain ⟨_, -, -, hr, -⟩ := Pattern.matches_inter.1 ⟨⟨_, _, r2⟩, ⟨_, _, l2'⟩⟩
       obtain ⟨rfl, rfl, ⟨⟩⟩ := pat_uniq l1 r1 h1 hr
@@ -893,7 +1495,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e
         let ⟨m3', h3, h4⟩ := this
         refine ⟨_, ?h3, .apply_pat hΓ (fun a _ _ => h4 a) ((?h3).hasType hΓ (H.hasType hΓ H1))⟩
         exact .apply_pat _ h3
-      clear H r l1 l2 l3 l4 this h1 h2 r1 r2 hr
+      clear H r l1 l2 l3 l4 l5 this h1 h2 r1 r2 hr
       induction l2' generalizing A with
       | const => exact ⟨nofun, nofun, nofun⟩
       | app _ _ ih1 ih2 =>
@@ -1038,6 +1640,32 @@ theorem hasType_app_bvar0
   have ⟨⟨_, f2⟩, _, f3⟩ := f1.hasType.1.lam_inv henv hΓ.1
   exact ⟨_, (HasType.lam f2 f3).defeqU_l henv hΓ.1 ⟨_, f1⟩⟩
 
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem ParRedExt.beta_defeq (l : ParRedExt) (W : l.depth ≤ Γ.length)
+    (H : Γ ⊢ l.apply ((lam A e').lift.app (bvar 0)) : T) :
+    Γ ⊢ l.apply ((lam A e').lift.app (bvar 0)) ≡ l.apply e' := by
+  induction l generalizing Γ T with
+  | base =>
+    simp only [apply] at H ⊢
+    have ⟨_, _, hfun, harg⟩ := H.app_inv henv hΓ
+    have ⟨⟨_, hA⟩, _, hbody⟩ := hfun.lam_inv henv hΓ
+    have ⟨⟨_, hdom⟩, _⟩ :=
+      ((hA.lam hbody).uniqU henv hΓ hfun).forallE_inv henv hΓ
+    simpa [liftN, instN_bvar0] using
+      (IsDefEq.toU (.beta hbody (hdom.symm.defeq harg)))
+  | lift l ih =>
+    let _ :: Γ' := Γ
+    have ⟨_, H'⟩ := (VExpr.WF.weakN_iff henv hΓ .one).1 ⟨_, H⟩
+    simpa [apply] using
+      (ih hΓ.1 (Nat.le_of_succ_le_succ W) H').weakN henv (.one)
+  | app l ih =>
+    let _ :: Γ' := Γ
+    obtain ⟨_, hfun⟩ := hasType_app_bvar0 hΓ H
+    have heq := ih hΓ.1 (Nat.le_of_succ_le_succ W) hfun
+    have happ := IsDefEq.appDF
+      ((heq.of_l henv hΓ.1 hfun).weakN henv .one) (.bvar .zero)
+    simpa [apply] using IsDefEq.toU happ
+
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem ParRedExt.parRed_beta :
     Γ ⊢ f ≡ₚ lam A e' → ∀ {a B}, Γ ⊢ f.app a : B → ∃ e, Γ ⊢ f.app a ≫* e ∧ Γ ⊢ e ≡ₚ e'.inst a := by
@@ -1071,6 +1699,17 @@ theorem ParRedExt.parRed_beta :
       have := a2.instN (.defeq u1 H2) .zero
       simp [inst, inst_lift] at this
       exact ⟨_, .rfl, this⟩
+    | structural hs =>
+      have ⟨_, _, H1, H2⟩ := h2.app_inv henv hΓ
+      have hsApp := hs.app hΓ H1 H2
+      have hse := hs.defeq hΓ
+      have hlam := (hse.of_l henv hΓ H1).hasType.2
+      have ⟨⟨_, hA⟩, _, hbody⟩ := hlam.lam_inv henv hΓ
+      have ⟨⟨_, hdom⟩, _⟩ :=
+        ((hA.lam hbody).uniqU henv hΓ hlam).forallE_inv henv hΓ
+      have hbeta : Γ ⊢ (lam A e').app a ≡ e'.inst a :=
+        ⟨_, .beta hbody (hdom.symm.defeq H2)⟩
+      exact ⟨_, .rfl, .structural (hsApp.trans_right hΓ hbeta)⟩
     | proofIrrel a1 a2 a3 =>
       have ⟨_, _, H1, H2⟩ := h2.app_inv henv hΓ
       have hf := a2.uniqU henv hΓ H1; have := a1.defeqU_l henv hΓ hf
@@ -1142,6 +1781,11 @@ theorem ParRedExt.parRed_beta :
     have ⟨_, c1⟩ := b2.defeq hΓ'
     let ⟨_, b3⟩ := hasType_app_bvar0 hΓ' c1.hasType.2
     exact ⟨_, .lam .rfl b1, .etaL b3 b2⟩
+  | structural hs =>
+    subst eq
+    have ⟨_, heq⟩ := hs.defeq hΓ
+    exact ⟨_, .rfl, .structural <|
+      hs.trans_right hΓ (l.beta_defeq hΓ W heq.hasType.2)⟩
   | @proofIrrel _ p _ _ a1 a2 a3 =>
     subst eq; refine ⟨_, .rfl, .proofIrrel a1 a2 ?_⟩
     clear a2; induction l generalizing Γ p with
@@ -1174,6 +1818,33 @@ theorem ParRedExt.parRed_beta :
       exact .defeqU_r henv hΓ H.symm this
   | _ => cases l.isApp eq
 
+/-!
+`StructEq` retains an oriented, registered eta seed plus the complete typed
+constructor-spine congruence.  Consequently one parallel step at its right
+endpoint is absorbed without erasing that seed.  This is the common typed
+join for all six structure-eta interactions from the L4L-15B design:
+
+* constructor-major projector iota and an overlapping registered rule are
+  both `ParRed.extra`; each step retains its own typed equality certificate;
+* nested reconstructions retain their inner `etaL`/`etaR` seed when
+  `StructEq.trans_right` composes the outer endpoint;
+* beta and congruence steps inside the major, including every repeated
+  projector occurrence, are the `beta` and `app` parallel cases;
+* dependent later fields are transported by the common endpoint type in the
+  resulting `IsDefEq` proof; and
+* proof fields and Prop-valued structures use the same typed transport, with
+  `NormalEq.proofIrrel` remaining available for the residual proof endpoints.
+
+The helper is intentionally proved from `ParRed.defeq`, not assumed in
+`Params`; the generic pattern interface therefore remains responsible for
+the `.extra` overlap.
+-/
+variable! (hΓ : OnCtx Γ (IsType env univs)) in
+theorem StructEq.parRed_right (H : StructEq Γ e₁ e₂)
+    (R : Γ ⊢ e₂ ≫ e₂') : StructEq Γ e₁ e₂' := by
+  have ⟨_, heq⟩ := H.defeq hΓ
+  exact H.trans_right hΓ ⟨_, R.defeq hΓ heq.hasType.2⟩
+
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem NormalEq.parRed (H1 : Γ ⊢ e₁ ≡ₚ e₂) (H2 : Γ ⊢ e₂ ≫ e₂') :
     ∃ e₁', Γ ⊢ e₁ ≫* e₁' ∧ Γ ⊢ e₁' ≡ₚ e₂' := by
@@ -1183,11 +1854,24 @@ theorem NormalEq.parRed (H1 : Γ ⊢ e₁ ≡ₚ e₂) (H2 : Γ ⊢ e₂ ≫ e
     cases H2 with
     | sort => exact ⟨_, .tail .rfl .sort, .sortDF l1 l2 l3⟩
     | extra r1 r2 => cases r2
-  | constDF l1 l2 l3 l4 l5 =>
+  | @constDF c ci ls ls' _ l1 l2 l3 l4 l5 =>
     cases H2 with
     | const => exact ⟨_, .tail .rfl .const, .constDF l1 l2 l3 l4 l5⟩
-    | extra r1 r2 r3 r4 =>
-      sorry
+    | @extra p rr _ m1 m2 _ m2' r1 r2 r3 r4 r5 =>
+      -- The registered contraction fires at `ls'`; it fires equally at the
+      -- `≈`-equivalent `ls`, and the two contracta are `NormalEq` by level
+      -- congruence.  The pattern is `.const c`, so it captures nothing.
+      have hstep2 := ParRed.extra r1 r2 r3 r4 r5
+      cases r2
+      obtain ⟨T, hT⟩ := r4
+      refine ⟨rr.1.apply ls m2', .tail .rfl (.extra r1 .const ?_ ?_ nofun), ?_⟩
+      · exact r3.instL_equiv hΓ _ l2 l3 l5 nofun
+      · exact IsDefEqU.trans henv hΓ ⟨_, .constDF l1 l2 l3 l4 l5⟩ <|
+          IsDefEqU.trans henv hΓ ⟨T, hT⟩
+            ⟨T, IsDefEq.eqUpToLevels henv hΓ hT.hasType.2
+              (EqUpToLevels.symm' (EqUpToLevels.apply_instL rr.1 l2 l3 l5 nofun))⟩
+      · exact EqUpToLevels.normalEq_r hΓ (EqUpToLevels.apply_instL rr.1 l2 l3 l5 nofun)
+          (hstep2.hasType hΓ hT.hasType.1)
   | @appDF Γ f A B f₂ a b l1 l2 l3 l4 l5 l6 ih1 ih2 =>
     cases H2 with
     | app r1 r2 =>
@@ -1277,6 +1961,8 @@ theorem NormalEq.parRed (H1 : Γ ⊢ e₁ ≡ₚ e₂) (H2 : Γ ⊢ e₂ ≫ e
       | extra b1 b2 b3 b4 =>
         cases b2 with | app _ h => cases h | var => cases pat_not_var b1
     | extra _ r2 => cases r2
+  | structural hs =>
+    exact ⟨_, .rfl, .structural (hs.parRed_right hΓ H2)⟩
   | proofIrrel l1 l2 l3 => exact ⟨_, .rfl, .proofIrrel l1 l2 (H2.hasType hΓ l3)⟩
 
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
@@ -1340,13 +2026,51 @@ theorem CRDefEq.trans : Γ ⊢ e₁ ≫≪ e₂ → Γ ⊢ e₂ ≫≪ e₃ →
     let ⟨_, b1, b2⟩ := (r5.symm hΓ).parRedS hΓ m2
     exact ⟨l1, r2, _, _, .trans l3 a1, .trans r4 b1, a2.trans hΓ <| m3.trans hΓ (b2.symm hΓ)⟩
 
+/-- Operational coverage for the environment's registered equations.
+
+This is deliberately separate from `Params.Pat`: registering a `VDefEq`, or
+merely classifying a pattern, does not make a reduction available. For every
+registered equation and well-formed context, a consumer must supply endpoint
+typings plus parallel-reduction paths to endpoints related by `NormalEq`;
+that is exactly `CRDefEq`. Symmetry and congruence closure are then derived by
+Church--Rosser rather than assumed as additional oracle fields.
+
+At each pattern contraction, `ParRed.extra` independently requires a
+successful match, satisfied checks, and a typed equality from that particular
+redex to the instantiated template. Thus this oracle cannot turn registration
+or pattern membership into an automatically trusted rewrite. Lambda-tower
+registrations expose their useful pattern only underneath the tower, after
+beta collapse, without pretending that the closed tower itself matches a
+first-order pattern. -/
+class Params.Extension [Params] where
+  join : OnCtx Γ (env.IsType univs) →
+    env.defeqs df → (∀ l ∈ ls, l.WF univs) → ls.length = df.uvars →
+    CRDefEq Γ (df.lhs.instL ls) (df.rhs.instL ls)
+
+theorem Params.Extension.extra [Params.Extension]
+    (hΓ : OnCtx Γ (env.IsType univs))
+    (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF univs)
+    (hlevelsLength : ls.length = df.uvars) :
+    CRDefEq Γ (df.lhs.instL ls) (df.rhs.instL ls) :=
+  Params.Extension.join hΓ hreg hlevels hlevelsLength
+
+theorem Params.Extension.extra_symm [Params.Extension]
+    (hΓ : OnCtx Γ (env.IsType univs))
+    (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF univs)
+    (hlevelsLength : ls.length = df.uvars) :
+    CRDefEq Γ (df.rhs.instL ls) (df.lhs.instL ls) :=
+  (Params.Extension.extra hΓ hreg hlevels hlevelsLength).symm hΓ
+
+variable [Params.Extension]
+
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem IsDefEq.church_rosser
     (H : Γ ⊢ e₁ ≡ e₂ : A) : Γ ⊢ e₁ ≫≪ e₂ := by
   have mk {Γ e₁ e₂ A e₁' e₂'} (H : Γ ⊢ e₁ ≡ e₂ : A)
       (h1 : Γ ⊢ e₁ ≫* e₁') (h2 : Γ ⊢ e₂ ≫* e₂') (h3 : Γ ⊢ e₁' ≡ₚ e₂') : Γ ⊢ e₁≫≪ e₂ :=
     ⟨⟨_, H.hasType.1⟩, ⟨_, H.hasType.2⟩, _, _, h1, h2, h3⟩
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | bvar h => exact .refl hΓ (.bvar h)
   | symm _ ih => exact (ih hΓ).symm hΓ
   | trans _ _ ih1 ih2 => exact (ih1 hΓ).trans hΓ (ih2 hΓ)
@@ -1378,9 +2102,13 @@ theorem IsDefEq.church_rosser
   | eta h1 ih1 =>
     have := h1.hasType.1
     exact .normalEq hΓ <| .etaL this <| .refl <| .app (this.weak henv) (.bvar .zero)
+  | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hmajor hrebuild _ _ _ =>
+    exact .normalEq hΓ <| .structural <|
+      .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine
+        hmajor hmajor hrebuild hrebuild hmajor hrebuild hrebuild hmajor
   | proofIrrel h1 h2 h3 ih1 ih2 ih3 =>
     exact .normalEq hΓ <| .proofIrrel h1.hasType.1 h2.hasType.1 h3.hasType.1
   | @extra _ _ Γ h1 h2 h3 =>
-    have ⟨_, _, _, _, a1, a2, a3, a4⟩ := extra_pat h1 h2 h3 (Γ := Γ)
-    refine have h := .extra h1 h2 h3; mk h (.tail .rfl (.extra a1 a2 a3 fun _ => .rfl)) .rfl ?_
-    exact a4 ▸ .refl h.hasType.2
+    exact Params.Extension.extra hΓ h1 h2 h3
+  | nil | cons => trivial
diff --git a/Lean4Lean/Theory/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean
index de6f89cb..1e3ac97a 100644
--- a/Lean4Lean/Theory/Typing/Env.lean
+++ b/Lean4Lean/Theory/Typing/Env.lean
@@ -2,11 +2,20 @@ import Lean4Lean.Theory.Typing.Basic
 import Lean4Lean.Theory.VDecl
 import Lean4Lean.Theory.Quot
 import Lean4Lean.Theory.Inductive
+import Lean4Lean.Theory.NestedInductive
 
 namespace Lean4Lean
 
 def VDefVal.WF (env : VEnv) (ci : VDefVal) : Prop := env.HasType ci.uvars [] ci.value ci.type
 
+/-- Add a block of constants, without their defining equations. -/
+def VEnv.addConsts (env : VEnv) (cis : List VDefVal) : Option VEnv :=
+  cis.foldlM (fun env ci => env.addConst ci.name ci.toVConstant) env
+
+/-- Add the defining equations of a block, after all of its constants. -/
+def VEnv.addDefEqs (env : VEnv) (cis : List VDefVal) : VEnv :=
+  cis.foldl (fun env ci => env.addDefEq ci.toDefEq) env
+
 inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where
   | axiom :
     ci.WF env →
@@ -16,6 +25,11 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where
     ci.WF env →
     env.addConst ci.name ci.toVConstant = some env' →
     VDecl.WF env (.def ci) (env'.addDefEq ci.toDefEq)
+  | mutualDef :
+    (∀ ci ∈ cis, ci.toVConstant.WF env) →
+    env.addConsts cis = some env' →
+    (∀ ci ∈ cis, ci.WF env') →
+    VDecl.WF env (.mutualDef cis) (env'.addDefEqs cis)
   | opaque :
     ci.WF env →
     env.addConst ci.name ci.toVConstant = some env' →
@@ -35,10 +49,20 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where
     gen.WF env blockEnv →
     env.addInductBlockGeneration gen = some env' →
     VDecl.WF env (.induct decl) env'
+  | inductNested {nested : decl.NestedBlockChecked} :
+    nested.WF env →
+    env.addInductNested nested = some env' →
+    VDecl.WF env (.induct decl) env'
 
 inductive VEnv.WF' : List VDecl → VEnv → Prop where
   | empty : VEnv.WF' [] .empty
   | decl {env} : VDecl.WF env d env' → env.WF' ds → env'.WF' (d::ds)
+  /-- A checked structure-eta descriptor is an environment capability, not a
+  source declaration.  Keep it in the environment history without inventing
+  a `VDecl`; its subject-reduction certificate is exactly the premise used by
+  `Ordered.structEta`. -/
+  | structEta {env : VEnv} {rule : VStructEta} : rule.WF env → env.WF' ds →
+      (env.addStructEta rule).WF' ds
 
 def VEnv.WF (env : VEnv) : Prop := ∃ ds, VEnv.WF' ds env
 
diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean
index cedcfc16..09f61c18 100644
--- a/Lean4Lean/Theory/Typing/EnvLemmas.lean
+++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean
@@ -2,9 +2,89 @@ import Lean4Lean.Theory.Typing.Lemmas
 import Lean4Lean.Theory.Typing.Env
 import Lean4Lean.Theory.Typing.QuotLemmas
 import Lean4Lean.Theory.Typing.InductiveLemmas
+import Lean4Lean.Theory.Typing.NestedInductiveLemmas
 
 namespace Lean4Lean
 
+theorem VEnv.addConsts_le {env env' : VEnv} : ∀ {cis}, env.addConsts cis = some env' → env ≤ env'
+  | [], h => by cases h; exact .rfl
+  | _ :: _, h => by
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at h
+    obtain ⟨_, h1, h2⟩ := h
+    exact (addConst_le h1).trans (addConsts_le h2)
+
+theorem VEnv.addConst_eq_none {env : VEnv} {name ci}
+    (h : env.constants name = none) : ∃ env', env.addConst name ci = some env' := by
+  unfold VEnv.addConst; rw [h]; exact ⟨_, rfl⟩
+
+theorem VEnv.addConst_constants_eq {env env' : VEnv} {name ci}
+    (h : env.addConst name ci = some env') :
+    env'.constants = fun n => if name = n then some ci else env.constants n := by
+  unfold VEnv.addConst at h; split at h <;> cases h; rfl
+
+/-- A block of constants can be added as long as each name is fresh and the block has no
+duplicates; the latter is what `addMutual`'s `found` set checks. -/
+theorem VEnv.exists_addConsts {env : VEnv} : ∀ {cis : List VDefVal},
+    (∀ ci ∈ cis, env.constants ci.name = none) → (cis.map (·.name)).Nodup →
+    ∃ env', env.addConsts cis = some env'
+  | [], _, _ => ⟨_, rfl⟩
+  | ci :: cis, hfresh, hnd => by
+    obtain ⟨env₁, h₁⟩ := VEnv.addConst_eq_none (ci := ci.toVConstant) (hfresh _ (.head _))
+    rw [List.map_cons, List.nodup_cons] at hnd
+    have ⟨env₂, h₂⟩ := VEnv.exists_addConsts (env := env₁) (cis := cis) (fun c hc => ?_) hnd.2
+    · exact ⟨env₂, by simp [VEnv.addConsts, h₁]; exact h₂⟩
+    · rw [VEnv.addConst_constants_eq h₁]
+      have : ci.name ≠ c.name := fun h => hnd.1 (List.mem_map.2 ⟨c, hc, h.symm⟩)
+      simp [this, hfresh c (.tail _ hc)]
+
+theorem VEnv.addConsts_congr {env : VEnv} : ∀ {cis cis' : List VDefVal},
+    List.Forall₂ (fun a b => a.toVConstVal = b.toVConstVal) cis cis' →
+    env.addConsts cis = env.addConsts cis'
+  | [], [], _ => rfl
+  | a :: _, b :: _, .cons h t => by
+    have h1 : a.name = b.name := congrArg VConstVal.name h
+    have h2 : a.toVConstant = b.toVConstant := congrArg VConstVal.toVConstant h
+    show (env.addConst a.name a.toVConstant).bind _ = (env.addConst b.name b.toVConstant).bind _
+    rw [h1, h2]
+    cases env.addConst b.name b.toVConstant
+    · rfl
+    · exact VEnv.addConsts_congr t
+
+theorem VEnv.addConsts_ordered {env env' : VEnv} : ∀ {cis}, Ordered env →
+    (∀ ci ∈ cis, ci.toVConstant.WF env) → env.addConsts cis = some env' → Ordered env'
+  | [], h, _, e => by cases e; exact h
+  | _ :: _, h, hw, e => by
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at e
+    obtain ⟨_, h1, h2⟩ := e
+    refine VEnv.addConsts_ordered (.const h (hw _ (.head _)) h1) (fun c hc => ?_) h2
+    exact (hw c (.tail _ hc)).mono (VEnv.addConst_le h1)
+
+theorem VEnv.addConsts_constants {env env' : VEnv} : ∀ {cis}, env.addConsts cis = some env' →
+    ∀ ci ∈ cis, env'.constants ci.name = some ci.toVConstant
+  | [], _, _, hc => nomatch hc
+  | _ :: _, e, c, hc => by
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at e
+    obtain ⟨_, h1, h2⟩ := e
+    cases hc with
+    | head => exact (VEnv.addConsts_le h2).constants (VEnv.addConst_self h1)
+    | tail _ hc => exact VEnv.addConsts_constants h2 c hc
+
+theorem VEnv.addDefEqs_ordered : ∀ {env : VEnv} {cis}, Ordered env →
+    (∀ ci ∈ cis, env.constants ci.name = some ci.toVConstant) →
+    (∀ ci ∈ cis, ci.WF env) → Ordered (env.addDefEqs cis)
+  | _, [], h, _, _ => h
+  | env, ci :: cis, h, hmem, hw => by
+    have hci : ci.WF env := hw _ (.head _)
+    have hord : Ordered (env.addDefEq ci.toDefEq) := by
+      refine .defeq h ⟨?_, hci⟩
+      simp [VDefVal.toDefEq]
+      rw [← (hci.levelWF ⟨⟩).2.2.instL_id]
+      exact .const (hmem _ (.head _)) VLevel.id_WF (by simp)
+    show Ordered ((env.addDefEq ci.toDefEq).addDefEqs cis)
+    refine VEnv.addDefEqs_ordered hord (fun c hc => ?_) (fun c hc => ?_)
+    · exact (VEnv.addDefEq_le (df := ci.toDefEq)).constants (hmem c (.tail _ hc))
+    · exact (hw c (.tail _ hc)).mono VEnv.addDefEq_le
+
 theorem VEnv.WF.ordered : WF env → Ordered env
   | ⟨ds, H⟩ => by
     induction H with
@@ -18,10 +98,15 @@ theorem VEnv.WF.ordered : WF env → Ordered env
           rw [← (h1.levelWF ⟨⟩).2.2.instL_id]
           exact .const (addConst_self h2) VLevel.id_WF (by simp)
         · exact h1.mono (addConst_le h2)
+      | mutualDef h0 h1 h2 =>
+        exact VEnv.addDefEqs_ordered (VEnv.addConsts_ordered ih h0 h1)
+          (VEnv.addConsts_constants h1) h2
       | «opaque» h1 h2 => exact .const ih (h1.isType ih ⟨⟩) h2
       | «example» _ => exact ih
       | quot h1 h2 => exact addQuot_WF ih h1 h2
       | induct h1 h2 => exact addInductGeneration_WF ih h1 h2
       | inductBlock h1 h2 => exact addInductBlockGeneration_WF ih h1 h2
+      | inductNested h1 h2 => exact VEnv.addInductNested_WF ih h1 h2
+    | structEta hwf _ ih => exact .structEta ih hwf
 
 instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩
diff --git a/Lean4Lean/Theory/Typing/HeadReduction.lean b/Lean4Lean/Theory/Typing/HeadReduction.lean
index e452edb7..c0d1ef17 100644
--- a/Lean4Lean/Theory/Typing/HeadReduction.lean
+++ b/Lean4Lean/Theory/Typing/HeadReduction.lean
@@ -61,6 +61,7 @@ inductive WHRed (Γ : List VExpr) : VExpr → VExpr → Prop where
   | major : IsMajorPremise f → Γ ⊢ a ⤳ a' → Γ ⊢ .app f a ⤳ .app f a'
   | beta : Γ ⊢ .app (.lam A e) a ⤳ e.inst a
   | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 →
+    IsDefEqU env univs Γ e (r.1.apply m1 m2) →
     Γ ⊢ e ⤳ r.1.apply m1 m2
 
 theorem WHRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
@@ -69,16 +70,20 @@ theorem WHRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
   | app _ ih1 => exact .app (ih1 W)
   | major h1 _ ih1 => exact .major h1 (ih1 W)
   | beta => exact .beta
-  | extra h1 h2 h3 => exact .extra h1 h2 <| h3.map fun a b h => h.defeqDFC henv W
+  | extra h1 h2 h3 h4 =>
+    exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W) (h4.defeqDFC henv W)
 
 theorem WHRed.weak' (W : Ctx.Lift' ρ Γ Γ') :
     Γ ⊢ e1 ⤳ e2 → Γ' ⊢ e1.lift' ρ ⤳ e2.lift' ρ
   | .app h1 => .app (h1.weak' W)
   | .major h1 h2 => .major (IsMajorPremise.lift'.2 h1) (h2.weak' W)
   | .beta => by rw [VExpr.lift'_inst_hi]; exact .beta
-  | .extra h1 h2 h3 => by
+  | .extra h1 h2 h3 h4 => by
+    have h4 := h4.weak' henv W
+    rw [Pattern.RHS.apply_lift'] at h4
     rw [Pattern.RHS.apply_lift']
-    refine .extra h1 (Pattern.matches_lift'.2 ⟨_, h2, fun _ => rfl⟩) <| h3.map fun _ _ h => ?_
+    refine .extra h1 (Pattern.matches_lift'.2 ⟨_, h2, fun _ => rfl⟩)
+      (h3.map fun _ _ h => ?_) h4
     simp only [← Pattern.RHS.apply_lift']; exact h.weak' henv W
 
 theorem WHRed.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ⤳ e2) :
@@ -97,10 +102,12 @@ theorem WHRed.weakU_inv (W : Ctx.Lift' ρ Γ Γ') (H : Γ' ⊢ e1.lift' ρ ⤳ e
   | beta =>
     let .app e1 _ := e1; let .lam .. := e1; cases he
     simp [← VExpr.lift'_inst_hi, VExpr.lift'_inj]; exact .beta
-  | extra h1 h2 h3 =>
+  | extra h1 h2 h3 hsound =>
     subst he
     obtain ⟨_, h4, h5⟩ := Pattern.matches_lift'.1 h2; cases funext h5
-    refine ⟨_, (Pattern.RHS.apply_lift' _).symm, .extra h1 h4 <| h3.map fun _ _ h => ?_⟩
+    rw [← Pattern.RHS.apply_lift'] at hsound
+    refine ⟨_, (Pattern.RHS.apply_lift' _).symm, .extra h1 h4 (h3.map fun _ _ h => ?_)
+      ((IsDefEqU.weak'_iff henv hΓ W).1 hsound)⟩
     simp only [← Pattern.RHS.apply_lift'] at h
     exact (IsDefEqU.weak'_iff henv hΓ W).1 h
 
@@ -109,7 +116,7 @@ theorem WHRed.parRed (H : Γ ⊢ e1 ⤳ e2) : Γ ⊢ e1 ≫ e2 := by
   | app _ ih => exact .app ih .rfl
   | major _ _ ih => exact .app .rfl ih
   | beta => exact .beta .rfl .rfl
-  | extra h1 h2 h3 => exact .extra h1 h2 h3 fun _ => .rfl
+  | extra h1 h2 h3 h4 => exact .extra h1 h2 h3 h4 fun _ => .rfl
 
 variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem WHRed.defeq (H : Γ ⊢ e1 ⤳ e2) (he : Γ ⊢ e1 : A) : Γ ⊢ e1 ≡ e2 : A :=
@@ -125,9 +132,11 @@ theorem WHRed.instN (W : Ctx.InstN Γ₀ a A₀ k Γ₁ Γ)
   | app _ ih => exact .app ih
   | major h1 _ ih => exact .major h1.instN ih
   | beta => rw [(by apply inst_inst_hi : (inst ..).inst _ _ = _)]; exact .beta
-  | extra h1 h2 h3 =>
+  | extra h1 h2 h3 h4 =>
+    have h4 := h4.instN henv W H₀
+    rw [Pattern.RHS.instN_apply] at h4
     rw [Pattern.RHS.instN_apply]
-    exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀)
+    exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀) h4
 
 def WHNF (Γ : List VExpr) (e : VExpr) := ∀ e', ¬Γ ⊢ e ⤳ e'
 
@@ -429,19 +438,33 @@ theorem StRed.triangle (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂)
     have ⟨⟨_, u1⟩, _, u2⟩ := (c1.uniqU henv hΓ (hA.lam he)).forallE_inv henv hΓ
     exact .whRed (a1.trans a4.app |>.tail .beta) <|
       (ih2 W ha a3).instN (u1.defeq ha) .zero (ih1 (W.succ (a5.defeq hΓ hA)) he a6)
-  | @extra p r e₁ m1 m2 Γ₂ m2' h1 h2 h3 _ ih =>
+  | @extra p r e₀ m1 m2 Γ₂ m2' h1 h2 h3 h4 _ ih =>
     have hΓ := W.isType' hΓ₀
-    suffices ∀ p' m1 m2, Subpattern p' p → p'.Matches e₁ m1 m2 →
+    suffices ∀ p' m1 m2, Subpattern p' p → p'.Matches e₀ m1 m2 →
          ∃ e₁ m3, Γ₁ ⊢ e ⤳* e₁ ∧ p'.Matches e₁ m1 m3 ∧ (∀ x, Γ₁ ⊢ m3 x ⤳< m2 x) by
       let ⟨e₁, m3, a1, a2, a3⟩ := this _ _ _ .refl h2
-      have := (a1.hasType hΓ h).matches_inv hΓ a2
-      refine .whRed (.tail a1 (.extra h1 a2 <| h3.map fun a b ⟨_, h⟩ => ?_))
-        (.apply_pat _ fun x => let ⟨_, h⟩ := this x; ih x W h (a3 x))
-      replace h := h.defeqDFC henv (W.symm henv)
-      refine have {r} := IsDefEq.apply_pat hΓ (r := r) fun a A h => ?_
-        ⟨_, (this h.hasType.1).symm.trans <| h.trans (this h.hasType.2)⟩
-      let ⟨_, h'⟩ := this a; exact ⟨_, ((a3 a).defeq hΓ h').symm⟩
-    clear h2 ih h; intro p' m1 m2 hp h2
+      have hcap := (a1.hasType hΓ h).matches_inv hΓ a2
+      have hcheck : r.2.OK (IsDefEqU env univs Γ₁) m1 m3 :=
+        h3.map fun a b ⟨_, hc⟩ => by
+        replace hc := hc.defeqDFC henv (W.symm henv)
+        have move {rhs : p.RHS} {T}
+            (ht : Γ₁ ⊢ rhs.apply m1 m2 : T) :
+            Γ₁ ⊢ rhs.apply m1 m2 ≡ rhs.apply m1 m3 : T :=
+          IsDefEq.apply_pat hΓ
+            (fun a _ _ => let ⟨_, ha⟩ := hcap a; ⟨_, ((a3 a).defeq hΓ ha).symm⟩) ht
+        exact ⟨_, (move hc.hasType.1).symm.trans <| hc.trans (move hc.hasType.2)⟩
+      have hsound₀ := h4.defeqDFC henv (W.symm henv)
+      have he' : IsDefEqU env univs Γ₁ e₁ e₀ :=
+        ⟨_, (a1.defeq hΓ h).symm.trans (H1.defeq hΓ h)⟩
+      have hrhs : IsDefEqU env univs Γ₁ (r.1.apply m1 m2) (r.1.apply m1 m3) :=
+        ⟨_, IsDefEq.apply_pat hΓ
+          (fun a _ _ => let ⟨_, ha⟩ := hcap a; ⟨_, ((a3 a).defeq hΓ ha).symm⟩)
+          hsound₀.choose_spec.hasType.2⟩
+      have hsound := IsDefEqU.trans henv hΓ he'
+        (IsDefEqU.trans henv hΓ hsound₀ hrhs)
+      refine .whRed (.tail a1 (.extra h1 a2 hcheck hsound))
+        (.apply_pat _ fun x => let ⟨_, h⟩ := hcap x; ih x W h (a3 x))
+    clear h2 h4 ih h; intro p' m1 m2 hp h2
     induction h2 generalizing e with
     | const => let .const H1 := H1; exact ⟨_, _, H1, .const, nofun⟩
     | app l1 l2 ih1 ih2 =>
@@ -466,7 +489,7 @@ variable! (hΓ : OnCtx Γ (IsType env univs)) in
 theorem ParRedS.standard (h : Γ ⊢ e : A) (H : Γ ⊢ e ≫* e') : Γ ⊢ e ⤳< e' :=
   .triangleS hΓ .zero h .rfl H
 
-variable! (hΓ : OnCtx Γ (IsType env univs)) in
+variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in
 theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) :
     ∃ u', Γ ⊢ e ⤳* .sort u' ∧ u' ≈ u := by
   have ⟨_, _, e', _, h1, h2, h3⟩ := H.church_rosser hΓ
@@ -477,6 +500,7 @@ theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) :
     | refl => exact ⟨_, rfl, rfl⟩
     | sortDF _ _ h => exact ⟨_, rfl, h⟩
     | etaL h => cases ((HasType.sort hu).uniqU henv hΓ h).sort_forallE_inv henv hΓ
+    | structural hs => exact (hs.not_sort_r hΓ hu).elim
     | proofIrrel h1 _ h3 =>
       have := h1.defeqU_l henv hΓ ((HasType.sort hu).uniqU henv hΓ h3).symm
       have := ((HasType.sort (by exact hu)).uniqU henv hΓ this).sort_inv henv hΓ
@@ -484,7 +508,7 @@ theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) :
   let .sort h1 := h1.standard hΓ H.hasType.1
   exact ⟨_, h1, a1⟩
 
-variable! (hΓ : OnCtx Γ (IsType env univs)) in
+variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in
 theorem IsDefEq.reduce_forallE (H : Γ ⊢ e ≡ .forallE A B : V) :
     ∃ A' B', Γ ⊢ e ⤳* .forallE A' B' := by
   have ⟨_, _, e', _, h1, h2, h3⟩ := H.church_rosser hΓ
@@ -497,6 +521,7 @@ theorem IsDefEq.reduce_forallE (H : Γ ⊢ e ≡ .forallE A B : V) :
     | refl
     | forallEDF _ _ h => exact ⟨_, _, rfl⟩
     | etaL h => cases ((hA₁.hasType.2.forallE hB₁).uniqU henv hΓ h).sort_forallE_inv henv hΓ
+    | structural hs => exact (hs.not_forallE_r hΓ (hA₁.hasType.2.forallE hB₁)).elim
     | proofIrrel h1 _ h3 =>
       have := h1.defeqU_l henv hΓ ((hA₁.hasType.2.forallE hB₁).uniqU henv hΓ h3).symm
       have := ((HasType.sort (by exact this.sort_inv henv)).uniqU henv hΓ this).sort_inv henv hΓ
@@ -629,7 +654,7 @@ theorem InferType.inst (H₀ : Γ ⊢ a ▷ A₀) (H : A₀::Γ ⊢ e ▷ A) :
   have ⟨_, hA⟩ := (H₀.hasType hΓ).isType henv hΓ
   .instN hΓ (by exact ⟨hΓ, _, hA⟩) H₀ .zero H
 
-variable! (hΓ : OnCtx Γ (IsType env univs)) in
+variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in
 theorem InferType.exists (H : Γ ⊢ a : A) : ∃ A', Γ ⊢ a ▷ A' := by
   replace H := (H.strong henv hΓ).hasType'.1
   generalize true = b at H
diff --git a/Lean4Lean/Theory/Typing/InductiveCertificate.lean b/Lean4Lean/Theory/Typing/InductiveCertificate.lean
new file mode 100644
index 00000000..f7ea85eb
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/InductiveCertificate.lean
@@ -0,0 +1,517 @@
+import Lean4Lean.Theory.Typing.EnvLemmas
+import Lean4Lean.Theory.Typing.InductivePattern
+import Lean4Lean.Theory.Typing.NestedInductiveLemmas
+
+/-!
+# Consumer certificates for completed inductive blocks
+
+`BlockGenerationCertificate` is the semantic input to the block transaction.
+This module packages that input with one successful transaction and a
+well-formed dependency environment, then exports the stable consequences a
+consumer needs.  The package contains only Theory values and proofs: no
+implementation metadata, checker state, or normalization execution crosses
+this boundary.
+
+In particular, `BlockCertificate.ruleClosure` derives the closed payload
+required by the generated-pattern API from the registered, well-formed iota
+rules in the completed environment.  A consumer therefore does not need a
+second closedness assumption in order to use `IotaPat`.
+-/
+
+namespace Lean4Lean
+
+namespace VInductDecl
+
+/-- One successful proof-carrying block transaction over an explicit
+dependency environment. -/
+structure BlockCertificate (source : VInductDecl) (before after : VEnv) where
+  semantic : source.BlockGenerationCertificate before
+  success : before.addInductBlockCertified semantic = some after
+  beforeWF : before.WF
+
+namespace BlockCertificate
+
+variable {source : VInductDecl} {before after : VEnv}
+
+/-- Package the ordinary raw `addInduct` entry point once its accepted block
+descriptor and semantic proof are known.  This is the compatibility bridge
+for consumers that still execute `addInduct`; no second transaction is run. -/
+def ofAddInduct
+    (generation : source.BlockGenerationChecked) (blockEnv : VEnv)
+    (hidentity : source.identityBlockGeneration? = some generation)
+    (hwf : generation.WF before blockEnv) (hbefore : before.WF)
+    (hadd : before.addInduct source = some after) :
+    BlockCertificate source before after where
+  semantic := ⟨generation, blockEnv, hwf⟩
+  success := by
+    unfold VEnv.addInduct at hadd
+    rw [hidentity] at hadd
+    exact hadd
+  beforeWF := hbefore
+
+/-- The exact generation descriptor retained by a completed block. -/
+abbrev generation (certificate : BlockCertificate source before after) :
+    source.BlockGenerationChecked :=
+  certificate.semantic.generation
+
+/-- Recover the four exact insertion phases of the completed block. -/
+theorem trace (certificate : BlockCertificate source before after) :
+    Nonempty (VEnv.AddInductBlockGenerationTrace before after
+      certificate.generation) :=
+  VEnv.addInductBlockCertified_trace certificate.success
+
+/-- The completed transaction is a genuine block declaration step. -/
+theorem declWF (certificate : BlockCertificate source before after) :
+    VDecl.WF before (.induct source) after := by
+  apply VDecl.WF.inductBlock certificate.semantic.wf
+  simpa only [VEnv.addInductBlockCertified_eq_addInductBlockGeneration] using
+    certificate.success
+
+/-- Extend the dependency-environment history with the certified block. -/
+theorem afterWF (certificate : BlockCertificate source before after) :
+    after.WF := by
+  rcases certificate.beforeWF with ⟨decls, hdecls⟩
+  exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩
+
+/-- A completed block only grows its dependency environment. -/
+theorem envLE (certificate : BlockCertificate source before after) :
+    before ≤ after := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.le
+
+/-- Compatibility spelling for consumers of the historical
+`addInduct_le` growth theorem. -/
+theorem addInduct_le (certificate : BlockCertificate source before after) :
+    before ≤ after :=
+  certificate.envLE
+
+/-- Compatibility spelling for the preservation result traditionally
+exported as `addInduct_WF`. -/
+theorem addInduct_WF (certificate : BlockCertificate source before after) :
+    after.WF :=
+  certificate.afterWF
+
+/-- Recover success through the ordinary raw API when this certificate's
+descriptor is the declaration's identity descriptor. -/
+theorem addInduct
+    (certificate : BlockCertificate source before after)
+    (hidentity : source.identityBlockGeneration? =
+      some certificate.generation) :
+    before.addInduct source = some after := by
+  unfold VEnv.addInduct
+  rw [hidentity]
+  simpa [VEnv.addInductBlockCertified] using certificate.success
+
+/-- Every source family has its exact stored Theory value in the completed
+environment. -/
+theorem familyLookup (certificate : BlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types) :
+    after.constants family.name = some family.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.family_lookup hfamily
+
+/-- Every flattened source constructor has its exact stored Theory value in
+the completed environment. -/
+theorem constructorLookup
+    (certificate : BlockCertificate source before after)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ source.blockConstructorConstants) :
+    after.constants constructor.name = some constructor.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.ctor_lookup hconstructor
+
+/-- Every generated family recursor has its exact Theory value in the
+completed environment. -/
+theorem recursorLookup
+    (certificate : BlockCertificate source before after)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ certificate.generation.recursors) :
+    after.constants recursor.name = some recursor.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rec_lookup hrecursor
+
+/-- A source family name was fresh at the dependency boundary. -/
+theorem familyFresh (certificate : BlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types) :
+    before.constants family.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.family_fresh hfamily
+
+/-- A flattened source constructor name was fresh at the dependency
+boundary. -/
+theorem constructorFresh
+    (certificate : BlockCertificate source before after)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ source.blockConstructorConstants) :
+    before.constants constructor.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.ctor_fresh hconstructor
+
+/-- A generated recursor name was fresh at the dependency boundary. -/
+theorem recursorFresh
+    (certificate : BlockCertificate source before after)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ certificate.generation.recursors) :
+    before.constants recursor.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rec_fresh hrecursor
+
+/-- Every generated rule is registered by the completed transaction. -/
+theorem ruleRegistered
+    (certificate : BlockCertificate source before after)
+    {rule : VDefEq}
+    (hrule : rule ∈ certificate.generation.generatedRules) :
+    after.defeqs rule := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rule_mem hrule
+
+/-- Every generated rule is well formed in the completed environment. -/
+theorem ruleWF
+    (certificate : BlockCertificate source before after)
+    {rule : VDefEq}
+    (hrule : rule ∈ certificate.generation.generatedRules) :
+    rule.WF after :=
+  certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule)
+
+/-- An exact family lookup is unique.  This small eliminator is convenient
+for consumers that translate their own family representation to a Theory
+constant and then compare it with the certificate inventory. -/
+theorem familyLookup_unique
+    (certificate : BlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types)
+    {constant : VConstant}
+    (hlookup : after.constants family.name = some constant) :
+    constant = family.toVConstant := by
+  exact Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily))
+
+/-- An exact constructor lookup is unique. -/
+theorem constructorLookup_unique
+    (certificate : BlockCertificate source before after)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ source.blockConstructorConstants)
+    {constant : VConstant}
+    (hlookup : after.constants constructor.name = some constant) :
+    constant = constructor.toVConstant := by
+  exact Option.some.inj
+    (hlookup.symm.trans (certificate.constructorLookup hconstructor))
+
+/-- An exact generated-recursor lookup is unique. -/
+theorem recursorLookup_unique
+    (certificate : BlockCertificate source before after)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ certificate.generation.recursors)
+    {constant : VConstant}
+    (hlookup : after.constants recursor.name = some constant) :
+    constant = recursor.toVConstant := by
+  exact Option.some.inj
+    (hlookup.symm.trans (certificate.recursorLookup hrecursor))
+
+private theorem rule_mem_generatedRules
+    (generation : source.BlockGenerationChecked)
+    {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : generation.flatCtors[i]? = some constructor) :
+    generation.rule i constructor ∈ generation.generatedRules := by
+  apply List.mem_map.2
+  refine ⟨(constructor, i), ?_, rfl⟩
+  apply List.mem_of_getElem? (i := i)
+  rw [List.getElem?_zipIdx, hentry, Option.map_some, Nat.zero_add]
+
+private theorem closedN_lamN_body :
+    ∀ {binders : List VExpr} {body : VExpr} {k : Nat},
+      (VExpr.lamN binders body).ClosedN k →
+        body.ClosedN (k + binders.length)
+  | [], _, _, h => by
+      simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using h
+  | _ :: binders, body, k, h => by
+      have hbody := closedN_lamN_body (binders := binders)
+        (body := body) (k := k + 1) h.2
+      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody
+
+private theorem closedN_lamN_replace :
+    ∀ {binders : List VExpr} {body body' : VExpr} {k : Nat},
+      (VExpr.lamN binders body).ClosedN k →
+      body'.ClosedN (k + binders.length) →
+        (VExpr.lamN binders body').ClosedN k
+  | [], _, _, _, _, hbody' => by
+      simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using hbody'
+  | _ :: binders, body, body', k, h, hbody' => by
+      refine ⟨h.1, closedN_lamN_replace (binders := binders)
+        (body := body) (body' := body') (k := k + 1) h.2 ?_⟩
+      simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody'
+
+private theorem closedN_appN_function :
+    ∀ {function : VExpr} {arguments : List VExpr} {k : Nat},
+      (VExpr.appN function arguments).ClosedN k → function.ClosedN k
+  | _, [], _, h => by simpa only [VExpr.appN] using h
+  | function, argument :: arguments, k, h =>
+      (closedN_appN_function (function := function.app argument)
+        (arguments := arguments) (k := k) h).1
+
+private theorem closedN_appN_argument
+    {function : VExpr} {arguments : List VExpr} {k : Nat}
+    (hclosed : (VExpr.appN function arguments).ClosedN k)
+    {argument : VExpr} (hargument : argument ∈ arguments) :
+    argument.ClosedN k := by
+  induction arguments generalizing function with
+  | nil => simp at hargument
+  | cons head tail ih =>
+    rcases List.mem_cons.1 hargument with heq | htail
+    · rw [heq]
+      exact (closedN_appN_function
+        (function := function.app head) (arguments := tail)
+        (k := k) hclosed).2
+    · exact ih (function := function.app head) hclosed htail
+
+/-- The successful block transaction supplies the closedness bundle required
+by `IotaPat`.  Closedness is derived from the registered rules and the
+completed environment's ordinary WF history; it is not an additional
+consumer assumption. -/
+theorem ruleClosure
+    (certificate : BlockCertificate source before after) :
+    certificate.generation.RuleClosure := by
+  constructor
+  · intro i constructor hentry
+    have hmem := rule_mem_generatedRules certificate.generation hentry
+    exact (certificate.ruleWF hmem).2.closedN
+      certificate.afterWF.ordered trivial
+  · intro constructor hconstructor expression hexpression
+    obtain ⟨i, hentry⟩ := List.mem_iff_getElem?.1 hconstructor
+    have hmem := rule_mem_generatedRules certificate.generation hentry
+    have hlhs := (certificate.ruleWF hmem).1.closedN
+      certificate.afterWF.ordered trivial
+    rw [certificate.generation.rule_lhs i constructor] at hlhs
+    have hbody := closedN_lamN_body hlhs
+    have hexpression' : expression ∈
+        certificate.generation.ruleIdx constructor ++
+          [certificate.generation.ruleCtorApp constructor] :=
+      List.mem_append.2 (.inl hexpression)
+    have hclosed : expression.ClosedN
+        (certificate.generation.ruleBinders constructor).length := by
+      apply closedN_appN_argument
+        (function := certificate.generation.recBase
+          (certificate.generation.ruleFieldCount constructor)
+          constructor.owner)
+        (arguments := certificate.generation.ruleIdx constructor ++
+          [certificate.generation.ruleCtorApp constructor])
+      · simpa only [BlockGenerationChecked.ruleLhsBody, List.length_nil,
+          Nat.zero_add] using hbody
+      · exact hexpression'
+    apply closedN_lamN_replace hlhs
+    simpa using hclosed
+
+/-- The exact generated pattern and payload associated with one flattened
+rule entry. -/
+theorem recursorPattern
+    (certificate : BlockCertificate source before after)
+    {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : certificate.generation.ruleEntry i constructor) :
+    certificate.generation.IotaPat certificate.ruleClosure
+      ((certificate.generation.rulePattern constructor).toPattern)
+      (certificate.generation.ruleRHS certificate.ruleClosure hentry,
+        certificate.generation.ruleCheck certificate.ruleClosure
+          (List.mem_of_getElem? hentry)) :=
+  .mk hentry
+
+/-- Rule-level consumer bundle: exact global position, generated-list
+membership, registration, well-formedness, and the corresponding L4L-10
+pattern all come from the same completed block. -/
+structure RecursorRuleFacts
+    (certificate : BlockCertificate source before after)
+    (i : Nat) (constructor : NormalizedBlockCtor) : Prop where
+  entry : certificate.generation.ruleEntry i constructor
+  member : certificate.generation.rule i constructor ∈
+    certificate.generation.generatedRules
+  registered : after.defeqs (certificate.generation.rule i constructor)
+  wf : (certificate.generation.rule i constructor).WF after
+  pattern : certificate.generation.IotaPat certificate.ruleClosure
+    ((certificate.generation.rulePattern constructor).toPattern)
+    (certificate.generation.ruleRHS certificate.ruleClosure entry,
+      certificate.generation.ruleCheck certificate.ruleClosure
+        (List.mem_of_getElem? entry))
+
+/-- Assemble all rule facts without a consumer-supplied semantic premise. -/
+theorem recursorRuleFacts
+    (certificate : BlockCertificate source before after)
+    {i : Nat} {constructor : NormalizedBlockCtor}
+    (hentry : certificate.generation.ruleEntry i constructor) :
+    certificate.RecursorRuleFacts i constructor := by
+  have hmember := rule_mem_generatedRules certificate.generation hentry
+  exact {
+    entry := hentry
+    member := hmember
+    registered := certificate.ruleRegistered hmember
+    wf := certificate.ruleWF hmember
+    pattern := certificate.recursorPattern hentry }
+
+end BlockCertificate
+
+/-! ## Completed nested transactions -/
+
+/-- One successful proof-carrying nested transaction over an explicit
+dependency environment.  As with `BlockCertificate`, this package contains
+only Theory artifacts. -/
+structure NestedBlockCertificate
+    (source : VInductDecl) (before after : VEnv) where
+  nested : source.NestedBlockChecked
+  semantic : nested.WF before
+  success : before.addInductNested nested = some after
+  beforeWF : before.WF
+
+namespace NestedBlockCertificate
+
+variable {source : VInductDecl} {before after : VEnv}
+
+/-- Recover the exact four-phase nested transaction trace. -/
+theorem trace (certificate : NestedBlockCertificate source before after) :
+    Nonempty (VEnv.AddInductNestedTrace before after certificate.nested) :=
+  VEnv.addInductNested_trace certificate.success
+
+/-- The nested completion is a genuine inductive declaration step. -/
+theorem declWF (certificate : NestedBlockCertificate source before after) :
+    VDecl.WF before (.induct source) after :=
+  .inductNested certificate.semantic certificate.success
+
+/-- Extend the dependency-environment history with the nested block. -/
+theorem afterWF (certificate : NestedBlockCertificate source before after) :
+    after.WF := by
+  rcases certificate.beforeWF with ⟨decls, hdecls⟩
+  exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩
+
+/-- A completed nested transaction only grows its dependency environment. -/
+theorem envLE (certificate : NestedBlockCertificate source before after) :
+    before ≤ after :=
+  VEnv.addInductNested_le certificate.success
+
+/-- Nested analogue of the public block growth result. -/
+theorem addInduct_le
+    (certificate : NestedBlockCertificate source before after) :
+    before ≤ after :=
+  certificate.envLE
+
+/-- Nested analogue of the public block preservation result. -/
+theorem addInduct_WF
+    (certificate : NestedBlockCertificate source before after) :
+    after.WF :=
+  certificate.afterWF
+
+/-- Every stored source family has its exact final value. -/
+theorem familyLookup (certificate : NestedBlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types) :
+    after.constants family.name = some family.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.family_lookup hfamily
+
+/-- Every stored source constructor has its exact final value. -/
+theorem constructorLookup
+    (certificate : NestedBlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types)
+    {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors) :
+    after.constants constructor.name = some constructor.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.ctor_lookup hfamily hconstructor
+
+/-- Every restored recursor has its exact final value. -/
+theorem recursorLookup
+    (certificate : NestedBlockCertificate source before after)
+    {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) :
+    after.constants recursor.name = some recursor.toVConstant := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rec_lookup hrecursor
+
+/-- Every source family name was fresh at the dependency boundary. -/
+theorem familyFresh (certificate : NestedBlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types) :
+    before.constants family.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.family_fresh hfamily
+
+/-- Every flattened source constructor name was fresh at the dependency
+boundary. -/
+theorem constructorFresh
+    (certificate : NestedBlockCertificate source before after)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ source.blockConstructorConstants) :
+    before.constants constructor.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.ctor_fresh hconstructor
+
+/-- Every restored recursor name was fresh at the dependency boundary. -/
+theorem recursorFresh
+    (certificate : NestedBlockCertificate source before after)
+    {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) :
+    before.constants recursor.name = none := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rec_fresh hrecursor
+
+/-- Every restored rule is registered in the completed environment. -/
+theorem ruleRegistered
+    (certificate : NestedBlockCertificate source before after)
+    {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) :
+    after.defeqs rule := by
+  rcases certificate.trace with ⟨trace⟩
+  exact trace.rule_mem hrule
+
+/-- Every registered restored rule is well formed. -/
+theorem ruleWF
+    (certificate : NestedBlockCertificate source before after)
+    {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) :
+    rule.WF after :=
+  certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule)
+
+/-- Exact family lookups are unique. -/
+theorem familyLookup_unique
+    (certificate : NestedBlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types)
+    {constant : VConstant}
+    (hlookup : after.constants family.name = some constant) :
+    constant = family.toVConstant :=
+  Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily))
+
+/-- Exact constructor lookups are unique. -/
+theorem constructorLookup_unique
+    (certificate : NestedBlockCertificate source before after)
+    {family : VInductiveType} (hfamily : family ∈ source.types)
+    {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors)
+    {constant : VConstant}
+    (hlookup : after.constants constructor.name = some constant) :
+    constant = constructor.toVConstant :=
+  Option.some.inj
+    (hlookup.symm.trans (certificate.constructorLookup hfamily hconstructor))
+
+/-- Exact restored-recursor lookups are unique. -/
+theorem recursorLookup_unique
+    (certificate : NestedBlockCertificate source before after)
+    {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors)
+    {constant : VConstant}
+    (hlookup : after.constants recursor.name = some constant) :
+    constant = recursor.toVConstant :=
+  Option.some.inj
+    (hlookup.symm.trans (certificate.recursorLookup hrecursor))
+
+end NestedBlockCertificate
+
+end VInductDecl
+
+end Lean4Lean
+
+/-! ## Exact Theory trust guards -/
+
+/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockCertificate.afterWF
+
+/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.ruleClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockCertificate.ruleClosure
+
+/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts
+
+/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF
+
+/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF
diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean
index ce2f7686..a07ade99 100644
--- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean
+++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean
@@ -1,6 +1,7 @@
 import Lean4Lean.Theory.Typing.Lemmas
 import Lean4Lean.Theory.Typing.Env
 import Lean4Lean.Theory.Typing.Meta
+import Lean4Lean.Theory.Typing.Strong
 
 namespace Lean4Lean
 
@@ -42,12 +43,6 @@ theorem instL_forallN (ls : List VLevel) (As : List VExpr) (e : VExpr) :
   | nil => rfl
   | cons A As ih => simp [forallN, instL, ih]
 
-theorem instL_appN (ls : List VLevel) (as : List VExpr) (f : VExpr) :
-    (appN f as).instL ls = appN (f.instL ls) (as.map (instL ls)) := by
-  induction as generalizing f with
-  | nil => rfl
-  | cons a as ih => simp [appN, instL, ih]
-
 /-- Substituting a variable for the sole loose variable is a lift. -/
 theorem inst_bvar_of_closedN (h : ClosedN e (k+1)) :
     e.inst (.bvar n) k = e.liftN n k := by
@@ -92,14 +87,6 @@ theorem appN_append (f : VExpr) : ∀ (as bs : List VExpr),
   | [], _ => rfl
   | a :: as, bs => appN_append (f.app a) as bs
 
-theorem liftN_appN (n k : Nat) (f : VExpr) : ∀ (as : List VExpr),
-    (f.appN as).liftN n k = appN (f.liftN n k) (as.map (liftN n · k))
-  | [] => rfl
-  | a :: as => by
-    show (VExpr.appN (f.app a) as).liftN n k = _
-    rw [liftN_appN n k (f.app a) as]
-    rfl
-
 theorem bvarRevRange_liftN_low : ∀ (m off n : Nat),
     (bvarRevRange off m).map (liftN n · 0) = bvarRevRange (n + off) m
   | 0, _, _ => rfl
@@ -319,14 +306,6 @@ theorem liftTelN_liftN_midN :
     rw [show j+d+1 = j+1+d from by omega]
     exact liftTelN_liftN_midN tel a k d (Nat.succ_le_succ hc)
 
-theorem instN_appN (a : VExpr) (k : Nat) (f : VExpr) : ∀ (as : List VExpr),
-    (f.appN as).inst a k = appN (f.inst a k) (as.map (·.inst a k))
-  | [] => rfl
-  | e :: as => by
-    show (VExpr.appN (f.app e) as).inst a k = _
-    rw [instN_appN a k (f.app e) as]
-    rfl
-
 /-- Instantiation under a telescope: the entry at depth `q` instantiates
 at `k+q`. -/
 def instTelN (a : VExpr) : List VExpr → Nat → List VExpr
@@ -1529,6 +1508,49 @@ theorem getElem?_stack_mid {α} (Δ mid Γ : List α) {i : Nat}
 
 namespace VEnv
 
+/-- A typed Theory expression cannot mention a constant absent from its
+environment. -/
+theorem HasType.hasConst_false_of_absent
+    {env : VEnv} {U : Nat} {Γ : List VExpr}
+    {name : Name} {e A : VExpr}
+    (henv : env.Ordered) (hΓ : OnCtx Γ (env.IsType U))
+    (absent : env.constants name = none)
+    (typed : env.HasType U Γ e A) :
+    e.hasConst name = false := by
+  induction e generalizing Γ A with
+  | bvar | sort => rfl
+  | const constant levels =>
+      by_cases equality : constant = name
+      · subst constant
+        obtain ⟨ci, present, levelWF, arity⟩ :=
+          typed.const_inv henv hΓ
+        rw [absent] at present
+        contradiction
+      · simpa [VExpr.hasConst, equality]
+  | app function argument functionIH argumentIH =>
+      obtain ⟨domain, body, functionType, argumentType⟩ :=
+        typed.app_inv henv hΓ
+      simp only [VExpr.hasConst, functionIH hΓ functionType,
+        argumentIH hΓ argumentType, Bool.false_or]
+  | lam domain body domainIH bodyIH =>
+      obtain ⟨domainType, bodyWF⟩ := typed.lam_inv henv hΓ
+      obtain ⟨domainLevel, domainHasType⟩ := domainType
+      obtain ⟨bodyType, bodyHasType⟩ := bodyWF
+      have nextContextWF : OnCtx (domain :: Γ) (env.IsType U) := by
+        change OnCtx Γ (env.IsType U) ∧ env.IsType U Γ domain
+        exact ⟨hΓ, ⟨domainLevel, domainHasType⟩⟩
+      simp only [VExpr.hasConst, domainIH hΓ domainHasType,
+        bodyIH nextContextWF bodyHasType, Bool.false_or]
+  | forallE domain body domainIH bodyIH =>
+      obtain ⟨domainType, bodyType⟩ := typed.forallE_inv henv
+      obtain ⟨domainLevel, domainHasType⟩ := domainType
+      obtain ⟨bodyLevel, bodyHasType⟩ := bodyType
+      have nextContextWF : OnCtx (domain :: Γ) (env.IsType U) := by
+        change OnCtx Γ (env.IsType U) ∧ env.IsType U Γ domain
+        exact ⟨hΓ, ⟨domainLevel, domainHasType⟩⟩
+      simp only [VExpr.hasConst, domainIH hΓ domainHasType,
+        bodyIH nextContextWF bodyHasType, Bool.false_or]
+
 /-- The spine `bvarRevRange Δ.length As.length` selects exactly the binders
 `As` (reversed into the context past `Δ`), when all of `As` are closed. -/
 theorem hasType_bvarRevRange {env : VEnv} {U : Nat} :
@@ -1702,47 +1724,39 @@ theorem SpineWF.hasType_appN {env : VEnv} {U : Nat} {Γ : List VExpr} :
     env.HasType U Γ f A → env.HasType U Γ (f.appN es) B := by
   intro es
   induction es with intro A B f h hf
-  | nil => exact h ▸ hf
+  | nil => cases h; exact hf
   | cons e es ih =>
-    obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h
-    exact ih hrest (hf.app he)
+      cases h with
+      | cons he hrest =>
+        exact ih hrest (hf.app he)
+
+/-- Concatenate two adjacent, well-typed application spines. -/
+theorem SpineWF.append {env : VEnv} {U : Nat} {Γ : List VExpr} :
+    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B →
+      ∀ {es' : List VExpr} {C : VExpr}, env.SpineWF U Γ B es' C →
+        env.SpineWF U Γ A (es ++ es') C
+  | [], _, _, .nil, _, _, h' => h'
+  | _ :: _, _, _, .cons he hrest, _, _, h' =>
+      .cons he (SpineWF.append hrest h')
+
+/-- Split a well-typed application spine at an explicit list prefix. -/
+theorem SpineWF.split {env : VEnv} {U : Nat} {Γ : List VExpr} :
+    ∀ {front suffix : List VExpr} {A B : VExpr},
+      env.SpineWF U Γ A (front ++ suffix) B →
+      ∃ cursor, env.SpineWF U Γ A front cursor ∧
+        env.SpineWF U Γ cursor suffix B
+  | [], suffix, A, B, h => ⟨A, .nil, by simpa using h⟩
+  | _ :: front, suffix, _, _, .cons he hrest => by
+      obtain ⟨cursor, hfront, hsuffix⟩ := SpineWF.split hrest
+      exact ⟨cursor, .cons he hfront, hsuffix⟩
 
 /-- Extend a well-typed application spine by one final argument. -/
 theorem SpineWF.snoc {env : VEnv} {U : Nat} {Γ : List VExpr} {e D C : VExpr} :
     ∀ {es : List VExpr} {A : VExpr}, env.SpineWF U Γ A es (.forallE D C) →
     env.HasType U Γ e D → env.SpineWF U Γ A (es ++ [e]) (C.inst e)
-  | [], A, h, he => by
-    subst A
-    exact ⟨D, C, rfl, he, rfl⟩
-  | a :: es, A, ⟨A₁, A₂, hA, ha, hrest⟩, he =>
-    ⟨A₁, A₂, hA, ha, SpineWF.snoc hrest he⟩
-
-theorem SpineWF.mono {env env' : VEnv} (henv : env ≤ env') {U : Nat} {Γ : List VExpr} :
-    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → env'.SpineWF U Γ A es B
-  | [], _, _, h => h
-  | _ :: _, _, _, ⟨A₁, A₂, hA, he, hrest⟩ =>
-    ⟨A₁, A₂, hA, he.mono henv, SpineWF.mono henv hrest⟩
-
-theorem SpineWF.instL {env : VEnv} {U U' : Nat} {ls : List VLevel}
-    (hls : ∀ l ∈ ls, l.WF U') {Γ : List VExpr} :
-    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B →
-    env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls)
-      (es.map (VExpr.instL ls)) (B.instL ls)
-  | [], _, _, h => congrArg (VExpr.instL ls) h
-  | _ :: es, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ =>
-    ⟨A₁.instL ls, A₂.instL ls, rfl, he.instL hls, by
-      have := SpineWF.instL hls (es := es) hrest
-      rwa [VExpr.instL_instN] at this⟩
-
-theorem SpineWF.weakN {env : VEnv} (henv : env.Ordered) {U n k : Nat} {Γ Γ' : List VExpr}
-    (W : Ctx.LiftN n k Γ Γ') :
-    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B →
-    env.SpineWF U Γ' (A.liftN n k) (es.map (VExpr.liftN n · k)) (B.liftN n k)
-  | [], _, _, h => congrArg (VExpr.liftN n · k) h
-  | _ :: es, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ =>
-    ⟨A₁.liftN n k, A₂.liftN n (k+1), rfl, he.weakN henv W, by
-      have := SpineWF.weakN henv W (es := es) hrest
-      rwa [VExpr.liftN_inst_hi] at this⟩
+  | [], _, .nil, he => .cons he .nil
+  | _ :: _, _, .cons ha hrest, he =>
+    .cons ha (SpineWF.snoc hrest he)
 
 /-- Retarget a spine judgment along a pi with the same domains: the
 result is the iterated instantiation of the new codomain. -/
@@ -1756,23 +1770,22 @@ theorem SpineWF.retarget {env : VEnv} {U : Nat} {Γ : List VExpr} {es : List VEx
       cases Δ with
       | nil => rfl
       | cons _ _ => simp at hlen
-    exact rfl
+    cases h
+    exact .nil
   | cons e es ih =>
     cases Δ with
     | nil => simp at hlen
     | cons A Δ =>
-      obtain ⟨A₁, A₂, hA, he, hrest⟩ := h
-      rw [show VExpr.forallN (A :: Δ) C = .forallE A (VExpr.forallN Δ C) from rfl] at hA
-      injection hA with h1 h2
-      subst h1; subst h2
-      have hlen' : es.length = Δ.length := by simpa using hlen
-      refine ⟨A, VExpr.forallN Δ C', rfl, he, ?_⟩
-      rw [VExpr.instN_forallN] at hrest
-      have := ih hrest (by simp [VExpr.instTelN_length, hlen']) (C'.inst e Δ.length)
-      show env.SpineWF U Γ ((VExpr.forallN Δ C').inst e) es
-        (VExpr.instRev (C'.inst e es.length) es)
-      rw [VExpr.instN_forallN, Nat.zero_add, hlen']
-      exact this
+      cases h with
+      | cons he hrest =>
+        have hlen' : es.length = Δ.length := by simpa using hlen
+        refine .cons he ?_
+        rw [VExpr.instN_forallN] at hrest
+        have := ih hrest (by simp [VExpr.instTelN_length, hlen']) (C'.inst e Δ.length)
+        show env.SpineWF U Γ ((VExpr.forallN Δ C').inst e) es
+          (VExpr.instRev (C'.inst e es.length) es)
+        rw [VExpr.instN_forallN, Nat.zero_add, hlen']
+        exact this
 
 /-- A spine consuming a full telescope and ending in the same sort has
 exactly one argument per telescope binder. -/
@@ -1781,20 +1794,14 @@ theorem SpineWF.forallN_sort_length
     ∀ {As es}, env.SpineWF U Γ (VExpr.forallN As (.sort l)) es (.sort l) →
       es.length = As.length
   | [], [], _ => rfl
-  | [], _ :: _, h => by
-    obtain ⟨A₁, A₂, hA, -⟩ := h
-    simp [VExpr.forallN] at hA
-  | _ :: _, [], h => by
-    simp [VEnv.SpineWF, VExpr.forallN] at h
+  | [], _ :: _, h => by cases h
+  | _ :: _, [], h => by cases h
   | A :: As, e :: es, h => by
-    obtain ⟨A₁, A₂, hA, he, hrest⟩ := h
-    simp only [VExpr.forallN] at hA
-    injection hA with h₁ h₂
-    subst A₁
-    subst A₂
-    rw [VExpr.instN_forallN] at hrest
-    have hlen := SpineWF.forallN_sort_length hrest
-    simpa [VExpr.instTelN_length] using congrArg Nat.succ hlen
+    cases h with
+    | cons he hrest =>
+      rw [VExpr.instN_forallN] at hrest
+      have hlen := SpineWF.forallN_sort_length hrest
+      simpa [VExpr.instTelN_length] using congrArg Nat.succ hlen
 
 end VEnv
 
@@ -2494,12 +2501,7 @@ theorem TelDefEq.spine_sort {env : VEnv} {U : Nat} (ord : env.Ordered) :
   | _, [], [], [], _, _, hsp, _ => by simpa using hsp
   | _, [], [], _ :: _, _, _, _, hlen => by simp at hlen
   | Γ, A :: As, A' :: As', e :: es, l, ⟨⟨_, hA⟩, hT⟩,
-      ⟨D, C, hshape, he, hrest⟩, hlen => by
-    change VExpr.forallE A' (VExpr.forallN As' (.sort l)) =
-      VExpr.forallE D C at hshape
-    injection hshape with hD hC
-    subst D
-    subst C
+      .cons he hrest, hlen => by
     have heRaw : env.HasType U Γ e A := hA.defeq' he
     have hTinst := TelDefEq.instN ord heRaw (.zero) hT
     have hrest' : env.SpineWF U Γ
@@ -2512,7 +2514,7 @@ theorem TelDefEq.spine_sort {env : VEnv} {U : Nat} (ord : env.Ordered) :
       rw [VExpr.instTelN_length]
       exact hlen'
     have hout := TelDefEq.spine_sort ord hTinst hrest' hlenInst
-    refine ⟨A, VExpr.forallN As (.sort l), rfl, heRaw, ?_⟩
+    refine .cons heRaw ?_
     simpa [VExpr.instN_forallN] using hout
 
 /-- Extend a definitionally equal context by the same well-formed telescope
@@ -2588,10 +2590,9 @@ contexts. -/
 theorem SpineWF.defeqDFC {env : VEnv} {U : Nat} (ord : env.Ordered)
     {Γ₀ Γ₁ Γ₂ : List VExpr} (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) :
     ∀ {A es B}, SpineWF env U Γ₁ A es B → SpineWF env U Γ₂ A es B
-  | _, [], _, h => h
-  | _, _ :: _, _, ⟨A₁, A₂, hA, he, hT⟩ =>
-    ⟨A₁, A₂, hA, he.defeqDFC ord hΓ,
-      SpineWF.defeqDFC ord hΓ hT⟩
+  | _, [], _, .nil => .nil
+  | _, _ :: _, _, .cons he hT =>
+    .cons (he.defeqDFC ord hΓ) (SpineWF.defeqDFC ord hΓ hT)
 
 /--
 info: 'Lean4Lean.VEnv.TelDefEq.raw_onTel' depends on axioms: [propext]
diff --git a/Lean4Lean/Theory/Typing/InductivePattern.lean b/Lean4Lean/Theory/Typing/InductivePattern.lean
new file mode 100644
index 00000000..d1c3d280
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/InductivePattern.lean
@@ -0,0 +1,774 @@
+import Lean4Lean.Theory.Typing.InductiveLemmas
+import Lean4Lean.Theory.Typing.Pattern
+
+/-! # Generated iota rules as patterns
+
+Every iota rule generated for a certified mutual block
+(`BlockGenerationChecked.rule`) is a closed defeq between lambda telescopes
+whose left body is a `SimplePattern.iota` spine: the owning family's recursor
+applied to the shared parameters, all motives, all minors, and the
+constructor's result indices, with a constructor-headed major premise. This
+module makes that connection exact and proves the generic pattern facts the
+Church–Rosser `Params` interface demands of one certified block:
+
+* `rulePattern` is the `SimplePattern` of one flattened constructor's rule,
+  and `ruleLhsBody_matches` matches the exact generated left body against it
+  at the rule's recursor levels.
+* `IotaPat` is the block's pattern set, associating each rule's pattern with
+  an RHS template (the registered right tower applied to the captured common
+  arguments and fields) and a check list (parameter and result-index
+  agreement between the recursor spine and the major premise).
+* `pat_simple`, `pat_uniq`, `pat_app_l`, `pat_app_l_uniq`, and
+  `pat_app_uniq` are exactly the `Params` obligations, specialized to
+  `IotaPat`; their name-freshness inputs come from the certified block's
+  `blockGeneratedNames` nodup bit, and the major-arity agreement between
+  same-recursor rules comes from the analyzer's terminal `blockTarget?`
+  arity equation.
+
+No open-environment `Params` instance is installed here; the block supplies
+the facts, and soundness (`pat_wf`) plus the block-local environment
+assembler belong to the pattern-soundness milestone. -/
+
+namespace Lean4Lean
+
+open VExpr
+
+namespace VExpr
+
+@[simp] theorem bvarRevRange_length : ∀ (off m : Nat),
+    (bvarRevRange off m).length = m
+  | _, 0 => rfl
+  | off, m+1 => by simp [bvarRevRange, bvarRevRange_length off m]
+
+end VExpr
+
+/-- Extending a `HeadConstN` spine by an application spine. -/
+theorem HeadConstN.appN {c : Name} {ls : List VLevel} :
+    ∀ (as : List VExpr) {n : Nat} {f : VExpr}, HeadConstN c ls n f →
+      HeadConstN c ls (n + as.length) (VExpr.appN f as)
+  | [], _, _, h => h
+  | a :: as, n, f, h => by
+    have := HeadConstN.appN as (h.app (a := a))
+    show HeadConstN c ls (n + (as.length + 1)) (VExpr.appN (f.app a) as)
+    rwa [(by omega : n + (as.length + 1) = n + 1 + as.length)]
+
+namespace VInductDecl
+
+/-! ## Positional facts about the checked pairings -/
+
+theorem pairNormalizedFamilies_getElem? :
+    ∀ (raws : List VInductiveType) (views : List CheckedFamilyData) (t : Nat)
+      {family : NormalizedFamily},
+      (pairNormalizedFamilies raws views)[t]? = some family →
+      raws[t]? = some family.raw ∧ views[t]? = some family.view
+  | raw :: raws, view :: views, 0, family => by
+    intro h
+    cases h
+    exact ⟨rfl, rfl⟩
+  | raw :: raws, view :: views, t+1, family => by
+    intro h
+    simpa using pairNormalizedFamilies_getElem? raws views t
+      (by simpa [pairNormalizedFamilies] using h)
+  | [], _, t, _ => by intro h; simp [pairNormalizedFamilies] at h
+  | _ :: _, [], t, _ => by intro h; simp [pairNormalizedFamilies] at h
+
+theorem pairNormalizedCtors_getElem? :
+    ∀ (raws : List VConstVal) (views : List CheckedCtor) (t : Nat)
+      {ctor : NormalizedCtor},
+      (pairNormalizedCtors raws views)[t]? = some ctor →
+      raws[t]? = some ctor.raw ∧ views[t]? = some ctor.view
+  | raw :: raws, view :: views, 0, ctor => by
+    intro h
+    cases h
+    exact ⟨rfl, rfl⟩
+  | raw :: raws, view :: views, t+1, ctor => by
+    intro h
+    simpa using pairNormalizedCtors_getElem? raws views t
+      (by simpa [pairNormalizedCtors] using h)
+  | [], _, t, _ => by intro h; simp [pairNormalizedCtors] at h
+  | _ :: _, [], t, _ => by intro h; simp [pairNormalizedCtors] at h
+
+/-- The erased family-data spine reads back its exact member facts: ordinal
+consecutiveness, the indexing family, the analyzer equations, and the
+per-family acceptance bit. -/
+theorem CheckedFamilies.data_getElem? {source : VInductDecl} {params : List VExpr} :
+    ∀ {ord : Nat} {types : List VInductiveType}
+      (fs : CheckedFamilies source params ord types) (t : Nat)
+      {fd : CheckedFamilyData},
+      fs.data[t]? = some fd →
+      ∃ type, types[t]? = some type ∧ fd.ordinal = ord + t ∧ fd.value = type ∧
+        fd.indices = ctorFields (VExpr.dropN source.nparams type.type) ∧
+        fd.constructors = type.ctors.map (CheckedCtor.ofBlock source) ∧
+        blockFamilyCore source params (ord + t) type = true
+  | _, _, .nil, t, fd => by intro h; simp [CheckedFamilies.data] at h
+  | ord, _, .cons head tail, 0, fd => by
+    intro h
+    cases h
+    exact ⟨_, rfl, rfl, rfl, head.indices_eq, head.constructors_eq, head.accepted⟩
+  | ord, _, .cons head tail, t+1, fd => by
+    intro h
+    obtain ⟨type, h1, h2, h3, h4, h5, h6⟩ :=
+      CheckedFamilies.data_getElem? tail t (by simpa [CheckedFamilies.data] using h)
+    exact ⟨type, by simpa using h1, by omega, h3, h4, h5,
+      by rw [(by omega : ord + (t + 1) = ord + 1 + t)]; exact h6⟩
+
+/-! ## Arity extraction from the analyzer's terminal target check -/
+
+theorem blockTarget?_loop_length {U np j : Nat} {names : List Name}
+    {head : VExpr} {args : List VExpr} :
+    ∀ (headers : List FamilyHeader) (t : Nat) {target : Nat} {idxs : List VExpr},
+      blockTarget?.loop U np j names head args t headers = some (target, idxs) →
+      t ≤ target ∧ ∃ header, headers[target - t]? = some header ∧
+        args.length = np + header.indices ∧ idxs = args.drop np
+  | [], t, target, idxs => by intro h; simp [blockTarget?.loop] at h
+  | header :: headers, t, target, idxs => by
+    intro h
+    rw [blockTarget?.loop] at h
+    split at h
+    · rename_i hcond
+      cases h
+      simp only [Bool.and_eq_true, beq_iff_eq] at hcond
+      exact ⟨Nat.le_refl _, header, by simp, hcond.1.1.2, rfl⟩
+    · obtain ⟨hle, header', h1, h2, h3⟩ :=
+        blockTarget?_loop_length headers (t+1) h
+      refine ⟨Nat.le_of_succ_le hle, header', ?_, h2, h3⟩
+      rw [(by omega : target - t = (target - (t+1)) + 1)]
+      simpa using h1
+
+/-- A successful mutual target recognition pins the target's index arity to
+its family header. -/
+theorem blockTarget?_length {U np j : Nat} {headers : List FamilyHeader}
+    {names : List Name} {B : VExpr} {target : Nat} {idxs : List VExpr}
+    (h : blockTarget? U np j headers names B = some (target, idxs)) :
+    ∃ header, headers[target]? = some header ∧
+      (VExpr.appArgs B []).length = np + header.indices ∧
+      idxs = (VExpr.appArgs B []).drop np := by
+  rw [blockTarget?] at h
+  obtain ⟨hle, header, h1, h2, h3⟩ := blockTarget?_loop_length headers 0 h
+  exact ⟨header, by simpa using h1, h2, h3⟩
+
+/-- The terminal of an accepted mutual constructor shape is a successful
+`blockTarget?` recognition of the owner family, past all fields. -/
+theorem blockStage3Ctor_result {U np : Nat} {headers : List FamilyHeader}
+    {names : List Name} {owner : Nat} :
+    ∀ (B : VExpr) (j : Nat), blockStage3Ctor U np headers names owner j B = true →
+      ∃ idxs, blockTarget? U np (j + (ctorFields B).length) headers names
+        (VExpr.resultOf B) = some (owner, idxs) := by
+  intro B
+  induction B with
+    (intro j h
+     simp only [blockStage3Ctor] at h
+     try (split at h
+          · rename_i target idxs heq
+            refine ⟨idxs, ?_⟩
+            simp only [ctorFields, List.length_nil, Nat.add_zero, VExpr.resultOf]
+            rwa [(by simpa using h : target = owner)] at heq
+          · cases h))
+  | forallE A rest _ ihR =>
+    rw [Bool.and_eq_true] at h
+    obtain ⟨-, h2⟩ := h
+    obtain ⟨idxs, hidx⟩ := ihR (j+1) h2
+    refine ⟨idxs, ?_⟩
+    simp only [ctorFields, List.length_cons, VExpr.resultOf]
+    rwa [(by omega : j + ((ctorFields rest).length + 1) = j + 1 + (ctorFields rest).length)]
+
+/-! ## Name transport across the normalization boundary -/
+
+theorem sameCtorHeaders_names : ∀ {cs cs' : List VConstVal},
+    sameCtorHeaders cs cs' = true → cs.map (·.name) = cs'.map (·.name)
+  | [], [], _ => rfl
+  | c :: cs, c' :: cs', h => by
+    simp only [sameCtorHeaders, Bool.and_eq_true, beq_iff_eq] at h
+    simp only [List.map_cons, h.1.1, sameCtorHeaders_names h.2]
+  | [], _ :: _, h => by simp [sameCtorHeaders] at h
+  | _ :: _, [], h => by simp [sameCtorHeaders] at h
+
+theorem sameTypeHeaders_names : ∀ {tys tys' : List VInductiveType},
+    sameTypeHeaders tys tys' = true →
+    tys.map (·.name) = tys'.map (·.name) ∧
+      tys.flatMap (fun ty => ty.ctors.map (·.name)) =
+        tys'.flatMap (fun ty => ty.ctors.map (·.name))
+  | [], [], _ => ⟨rfl, rfl⟩
+  | ty :: tys, ty' :: tys', h => by
+    simp only [sameTypeHeaders, Bool.and_eq_true, beq_iff_eq] at h
+    have ih := sameTypeHeaders_names h.2
+    simp only [List.map_cons, List.flatMap_cons, h.1.1.1, ih.1, ih.2,
+      sameCtorHeaders_names h.1.2, and_self]
+  | [], _ :: _, h => by simp [sameTypeHeaders] at h
+  | _ :: _, [], h => by simp [sameTypeHeaders] at h
+
+/-- The reserved generated names are unchanged by normalization: they are
+computed from family and constructor identities only. -/
+theorem blockGeneratedNames_eq_of_sameTypeHeaders
+    {tys tys' : List VInductiveType} (h : sameTypeHeaders tys tys' = true) :
+    blockGeneratedNames tys = blockGeneratedNames tys' := by
+  obtain ⟨h1, h2⟩ := sameTypeHeaders_names h
+  have h3 : tys.map (fun ty => (.str ty.name "rec" : Name)) =
+      tys'.map (fun ty => (.str ty.name "rec" : Name)) := by
+    have := congrArg (List.map (fun n => (.str n "rec" : Name))) h1
+    simpa [List.map_map, Function.comp_def] using this
+  simp only [blockGeneratedNames, h1, h2, h3]
+
+namespace BlockGenerationChecked
+
+variable {source : VInductDecl} (gen : source.BlockGenerationChecked)
+
+/-! ## Inventory facts from the certified block -/
+
+include gen in
+/-- The reserved generated names of the raw source are collision-free: the
+analyzer certifies the view's inventory, and normalization retains every
+identity. -/
+theorem blockGeneratedNames_nodup :
+    (blockGeneratedNames source.types).Nodup := by
+  have hshape := gen.block.normalization.shape_eq
+  simp only [normalizationShape, Bool.and_eq_true, beq_iff_eq] at hshape
+  rw [blockGeneratedNames_eq_of_sameTypeHeaders hshape.2]
+  have h := gen.block.checked.names_nodup
+  rwa [gen.block.checked.names_eq] at h
+
+/-! ## Named components of one generated iota rule -/
+
+/-- Field count of one flattened constructor, as bound by its iota rule. -/
+def ruleFieldCount (constructor : NormalizedBlockCtor) : Nat :=
+  (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination).length
+
+/-- The result-index spine of one iota rule body, in the rule's binder
+context. -/
+def ruleIdx (constructor : NormalizedBlockCtor) : List VExpr :=
+  constructor.ctor.resultIndicesR source.uvars gen.elimination |>.map
+    fun e => e.liftN (gen.familyCount + gen.minorCount)
+      (gen.ruleFieldCount constructor)
+
+/-- The binder telescope shared by both towers of one iota rule. -/
+def ruleBinders (constructor : NormalizedBlockCtor) : List VExpr :=
+  gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++
+    VExpr.liftTelN (gen.familyCount + gen.minorCount)
+      (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination) 0
+
+/-- The constructor-headed major premise of one iota rule body. -/
+def ruleCtorApp (constructor : NormalizedBlockCtor) : VExpr :=
+  VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels)
+    (VExpr.bvarRevRange
+        (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount))
+        source.nparams ++
+      VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor))
+
+/-- The exact left body of one generated iota rule: the owner's recursor
+applied to the common arguments, the constructor's result indices, and the
+constructor-headed major premise. -/
+def ruleLhsBody (constructor : NormalizedBlockCtor) : VExpr :=
+  VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner)
+    (gen.ruleIdx constructor ++ [gen.ruleCtorApp constructor])
+
+/-- The generated rule's left side is exactly the shared binder telescope
+over the `SimplePattern.iota` spine. -/
+theorem rule_lhs (i : Nat) (constructor : NormalizedBlockCtor) :
+    (gen.rule i constructor).lhs =
+      VExpr.lamN (gen.ruleBinders constructor) (gen.ruleLhsBody constructor) := rfl
+
+/-! ## The pattern of one generated iota rule -/
+
+/-- The recursor constant owning one flattened constructor's iota rule. -/
+def ruleRecName (constructor : NormalizedBlockCtor) : Name :=
+  .str (gen.familyNameAt constructor.owner) "rec"
+
+/-- Major-argument arity of one iota rule: shared parameters, all motives,
+all minors, and the constructor's result indices. -/
+def ruleMajorArity (constructor : NormalizedBlockCtor) : Nat :=
+  source.nparams + gen.familyCount + gen.minorCount +
+    (constructor.ctor.resultIndicesR source.uvars gen.elimination).length
+
+/-- Argument arity of one iota rule's constructor-headed major premise. -/
+def ruleArgArity (constructor : NormalizedBlockCtor) : Nat :=
+  source.nparams + gen.ruleFieldCount constructor
+
+/-- The `SimplePattern` of one generated iota rule. -/
+@[reducible] def rulePattern (constructor : NormalizedBlockCtor) : SimplePattern :=
+  .iota (gen.ruleRecName constructor) (gen.ruleMajorArity constructor)
+    constructor.ctor.raw.name (gen.ruleArgArity constructor)
+
+/-- The generated left body is matched by the rule's pattern, at exactly the
+rule's recursor levels. -/
+theorem ruleLhsBody_matches (constructor : NormalizedBlockCtor) :
+    ∃ m2, ((gen.rulePattern constructor).toPattern).Matches
+      (gen.ruleLhsBody constructor) gen.recLevels m2 := by
+  rw [rulePattern, SimplePattern.toPattern_iota]
+  have hleft : HeadConstN (gen.ruleRecName constructor) gen.recLevels
+      (gen.ruleMajorArity constructor)
+      (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner)
+        (gen.ruleIdx constructor)) := by
+    have h0 : HeadConstN (gen.ruleRecName constructor) gen.recLevels 0
+        (.const (gen.ruleRecName constructor) gen.recLevels) := .const
+    have h1 := (h0.appN (VExpr.bvarRevRange (gen.ruleFieldCount constructor)
+      (source.nparams + gen.familyCount + gen.minorCount)))
+    have h2 := h1.appN (as := gen.ruleIdx constructor)
+    rw [VExpr.bvarRevRange_length] at h2
+    have harity : 0 + (source.nparams + gen.familyCount + gen.minorCount) +
+        (gen.ruleIdx constructor).length = gen.ruleMajorArity constructor := by
+      simp only [ruleIdx, ruleMajorArity, List.length_map]; omega
+    rwa [harity] at h2
+  have hright : HeadConstN constructor.ctor.raw.name gen.sourceLevels
+      (gen.ruleArgArity constructor) (gen.ruleCtorApp constructor) := by
+    have h0 : HeadConstN constructor.ctor.raw.name gen.sourceLevels 0
+        (.const constructor.ctor.raw.name gen.sourceLevels) := .const
+    have h1 := h0.appN (as := VExpr.bvarRevRange
+      (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount))
+      source.nparams ++ VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor))
+    rw [List.length_append, VExpr.bvarRevRange_length, VExpr.bvarRevRange_length] at h1
+    have harity : 0 + (source.nparams + gen.ruleFieldCount constructor) =
+        gen.ruleArgArity constructor := by simp only [ruleArgArity]; omega
+    rwa [harity] at h1
+  have hbody : gen.ruleLhsBody constructor =
+      .app (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner)
+          (gen.ruleIdx constructor))
+        (gen.ruleCtorApp constructor) := by
+    rw [ruleLhsBody, VExpr.appN_append]
+    rfl
+  rw [hbody]
+  exact RecursorIotaPattern.matches_of hleft hright
+
+/-! ## Positional anatomy of the flattened constructors -/
+
+/-- The checked spine assigns family ordinals positionally. -/
+theorem families_getElem?_ordinal {t : Nat} {family : NormalizedFamily}
+    (h : gen.families[t]? = some family) : family.view.ordinal = t := by
+  have h' : (pairNormalizedFamilies source.types
+      gen.block.checked.families.data)[t]? = some family := h
+  obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t h'
+  obtain ⟨type, -, hord, -, -, -, -⟩ := CheckedFamilies.data_getElem? _ t hview
+  simpa using hord
+
+/-- Position `t` of the paired family list is the `t`-th source family. -/
+theorem families_getElem?_raw {t : Nat} {family : NormalizedFamily}
+    (h : gen.families[t]? = some family) : source.types[t]? = some family.raw :=
+  (pairNormalizedFamilies_getElem? source.types
+    gen.block.checked.families.data t h).1
+
+/-- A family lookup names the owning recursor's family. -/
+theorem familyNameAt_eq {t : Nat} {family : NormalizedFamily}
+    (h : gen.families[t]? = some family) :
+    gen.familyNameAt t = family.raw.name := by
+  simp [familyNameAt, h]
+
+/-- One flattened constructor decomposes into its owner family lookup and
+its position inside that family's pairing. -/
+theorem flatCtors_anatomy {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ gen.flatCtors) :
+    ∃ t family, gen.families[t]? = some family ∧
+      constructor.owner = t ∧
+      constructor.familyName = family.raw.name ∧
+      constructor.familyIndices = family.view.indices ∧
+      constructor.ctor ∈ family.ctorPairs := by
+  have hc' : constructor ∈ gen.families.flatMap (·.blockCtors) := hc
+  rw [List.mem_flatMap] at hc'
+  obtain ⟨family, hfamily, hmem⟩ := hc'
+  obtain ⟨t, ht⟩ := List.mem_iff_getElem?.1 hfamily
+  simp only [NormalizedFamily.blockCtors, List.mem_map] at hmem
+  obtain ⟨ctor, hctor, rfl⟩ := hmem
+  exact ⟨t, family, ht, gen.families_getElem?_ordinal ht, rfl, rfl, hctor⟩
+
+/-! ## The analyzer's arity equation for pattern majors -/
+
+/-- Every flattened constructor's checked result-index spine has exactly its
+owner family's index arity: the analyzer's terminal `blockTarget?` equation
+transports through the checked spine. -/
+theorem view_resultIndices_length {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ gen.flatCtors) :
+    constructor.ctor.view.resultIndices.length =
+      constructor.familyIndices.length := by
+  obtain ⟨t, family, ht, -, -, hindices, hmem⟩ := gen.flatCtors_anatomy hc
+  have ht' : (pairNormalizedFamilies source.types
+      gen.block.checked.families.data)[t]? = some family := ht
+  obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t ht'
+  obtain ⟨vtype, hvty, -, -, hvindices, hvctors, hvcore⟩ :=
+    CheckedFamilies.data_getElem? _ t hview
+  rw [Nat.zero_add] at hvcore
+  obtain ⟨s, hs⟩ := List.mem_iff_getElem?.1 hmem
+  have hs' : (pairNormalizedCtors family.raw.ctors
+      family.view.constructors)[s]? = some constructor.ctor := hs
+  obtain ⟨-, hviewCtor⟩ := pairNormalizedCtors_getElem? _ _ s hs'
+  rw [hvctors, List.getElem?_map] at hviewCtor
+  obtain ⟨c₀, hc₀, hview_eq⟩ : ∃ c₀, vtype.ctors[s]? = some c₀ ∧
+      CheckedCtor.ofBlock _ c₀ = constructor.ctor.view := by
+    cases h0 : vtype.ctors[s]? with
+    | none => rw [h0] at hviewCtor; cases hviewCtor
+    | some c₀ => rw [h0] at hviewCtor; exact ⟨c₀, rfl, by simpa using hviewCtor⟩
+  simp only [blockFamilyCore, Bool.and_eq_true, beq_iff_eq,
+    List.all_eq_true] at hvcore
+  have hstage := (hvcore.2 c₀ (List.mem_of_getElem? hc₀)).2
+  obtain ⟨idxs, htarget⟩ := blockStage3Ctor_result _ 0 hstage
+  obtain ⟨header, hheader, hlen, -⟩ := blockTarget?_length htarget
+  rw [familyHeaders, List.getElem?_map, hvty, Option.map_some] at hheader
+  have hri : constructor.ctor.view.resultIndices =
+      (VExpr.appArgs (VExpr.resultOf (VExpr.dropN
+        gen.block.normalization.view.nparams c₀.type)) []).drop
+        gen.block.normalization.view.nparams := by
+    rw [← hview_eq]; rfl
+  rw [hri, hindices, hvindices, List.length_drop, hlen]
+  cases hheader
+  show gen.block.normalization.view.nparams +
+      (ctorFields (VExpr.dropN gen.block.normalization.view.nparams
+        vtype.type)).length -
+      gen.block.normalization.view.nparams =
+    (ctorFields (VExpr.dropN gen.block.normalization.view.nparams
+      vtype.type)).length
+  omega
+
+/-- Pattern major arity through the owner family's index count. -/
+theorem ruleMajorArity_eq {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ gen.flatCtors) :
+    gen.ruleMajorArity constructor =
+      source.nparams + gen.familyCount + gen.minorCount +
+        constructor.familyIndices.length := by
+  simp only [ruleMajorArity, NormalizedCtor.resultIndicesR, List.length_map,
+    gen.view_resultIndices_length hc]
+
+/-! ## Name freshness of the generated inventory -/
+
+include gen in
+private theorem nodup_parts :
+    (source.types.map (·.name)).Nodup ∧
+      (source.types.flatMap fun ty => ty.ctors.map (·.name)).Nodup ∧
+      ∀ a ∈ (source.types.flatMap fun ty => ty.ctors.map (·.name)),
+        ∀ b ∈ source.types.map (fun ty => (.str ty.name "rec" : Name)), a ≠ b := by
+  have h := gen.blockGeneratedNames_nodup
+  rw [blockGeneratedNames, List.nodup_append] at h
+  obtain ⟨hAB, -, hdisj⟩ := h
+  rw [List.nodup_append] at hAB
+  exact ⟨hAB.1, hAB.2.1, fun a ha b hb =>
+    hdisj a (List.mem_append.2 (.inr ha)) b hb⟩
+
+/-- Family positions are recoverable from raw family names. -/
+theorem families_name_inj {t t' : Nat} {family family' : NormalizedFamily}
+    (h : gen.families[t]? = some family) (h' : gen.families[t']? = some family')
+    (hname : family.raw.name = family'.raw.name) : t = t' := by
+  have h1 := gen.families_getElem?_raw h
+  have h1' := gen.families_getElem?_raw h'
+  have hm : (source.types.map (·.name))[t]? = some family.raw.name := by
+    rw [List.getElem?_map, h1, Option.map_some]
+  have hm' : (source.types.map (·.name))[t']? = some family.raw.name := by
+    rw [List.getElem?_map, h1', Option.map_some, hname]
+  obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm
+  exact (List.getElem?_inj hlt gen.nodup_parts.1).1 (hm.trans hm'.symm)
+
+/-- Flattened positions are recoverable from raw constructor names. -/
+theorem flatCtors_name_inj {i i' : Nat} {c c' : NormalizedBlockCtor}
+    (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c')
+    (hname : c.ctor.raw.name = c'.ctor.raw.name) : i = i' ∧ c = c' := by
+  have hnodup : ((source.blockConstructorConstants).map (·.name)).Nodup := by
+    rw [VInductDecl.blockConstructorConstants, List.map_flatMap]
+    exact gen.nodup_parts.2.1
+  have hm : ((source.blockConstructorConstants).map (·.name))[i]? =
+      some c.ctor.raw.name := by
+    rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h]
+    rfl
+  have hm' : ((source.blockConstructorConstants).map (·.name))[i']? =
+      some c.ctor.raw.name := by
+    rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h',
+      hname]
+    rfl
+  obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm
+  have hii : i = i' := (List.getElem?_inj hlt hnodup).1 (hm.trans hm'.symm)
+  subst hii
+  exact ⟨rfl, Option.some.inj (h.symm.trans h')⟩
+
+/-- No family's recursor name collides with any flattened constructor's
+name. -/
+theorem recName_ne_ctorName {family : NormalizedFamily}
+    (hfam : family ∈ gen.families) {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ gen.flatCtors) :
+    (.str family.raw.name "rec" : Name) ≠ constructor.ctor.raw.name := by
+  have hmemC : constructor.ctor.raw.name ∈
+      source.types.flatMap fun ty => ty.ctors.map (·.name) := by
+    have h1 : constructor.ctor.raw ∈ source.blockConstructorConstants := by
+      rw [← gen.flatCtors_map_raw]
+      exact List.mem_map_of_mem hc
+    rw [VInductDecl.blockConstructorConstants, List.mem_flatMap] at h1
+    obtain ⟨ty, hty, hmem⟩ := h1
+    rw [List.mem_flatMap]
+    exact ⟨ty, hty, List.mem_map_of_mem hmem⟩
+  have hmemR : (.str family.raw.name "rec" : Name) ∈
+      source.types.map (fun ty => (.str ty.name "rec" : Name)) := by
+    have h1 : family.raw ∈ source.types := by
+      rw [← gen.families_map_raw]
+      exact List.mem_map_of_mem hfam
+    exact List.mem_map_of_mem h1
+  intro heq
+  exact gen.nodup_parts.2.2 _ hmemC _ hmemR heq.symm
+
+/-- Two flattened constructors with the same owning recursor name share
+their owner and their family's index telescope. -/
+theorem ruleRecName_inj {c c' : NormalizedBlockCtor}
+    (hc : c ∈ gen.flatCtors) (hc' : c' ∈ gen.flatCtors)
+    (h : gen.ruleRecName c = gen.ruleRecName c') :
+    c.owner = c'.owner ∧ c.familyIndices = c'.familyIndices := by
+  obtain ⟨t, family, ht, ho, -, hi, -⟩ := gen.flatCtors_anatomy hc
+  obtain ⟨t', family', ht', ho', -, hi', -⟩ := gen.flatCtors_anatomy hc'
+  rw [ruleRecName, ruleRecName, ho, ho', gen.familyNameAt_eq ht,
+    gen.familyNameAt_eq ht'] at h
+  have hnames : family.raw.name = family'.raw.name := by
+    injection h with h1 h2
+  have ht2 : t = t' := gen.families_name_inj ht ht' hnames
+  subst ht2
+  cases Option.some.inj (ht.symm.trans ht')
+  exact ⟨ho.trans ho'.symm, hi.trans hi'.symm⟩
+
+/-- Rule distinctness: distinct flattened positions carry distinct
+patterns. -/
+theorem rulePattern_inj {i i' : Nat} {c c' : NormalizedBlockCtor}
+    (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c')
+    (heq : gen.rulePattern c = gen.rulePattern c') : i = i' ∧ c = c' := by
+  injection heq with h1 h2 h3 h4
+  exact gen.flatCtors_name_inj h h' h3
+
+/-! ## Rule payloads: RHS templates and agreement checks -/
+
+/-- Closedness inputs for one certified block's rule payloads: the towers a
+rule's RHS template and checks embed as fixed template constants. Concrete
+fixtures discharge this bundle by `decide`; the pattern-soundness milestone
+derives it from the staged environment's rule well-formedness. -/
+structure RuleClosure : Prop where
+  rhs_closed : ∀ ⦃i : Nat⦄ ⦃constructor : NormalizedBlockCtor⦄,
+    gen.flatCtors[i]? = some constructor →
+      ((gen.rule i constructor).rhs).ClosedN 0
+  idxTower_closed : ∀ ⦃constructor : NormalizedBlockCtor⦄,
+    constructor ∈ gen.flatCtors → ∀ e ∈ gen.ruleIdx constructor,
+      (VExpr.lamN (gen.ruleBinders constructor) e).ClosedN 0
+
+/-- The template capture list shared by every payload tower: the recursor
+side's parameters, motives, and minors, then the major premise's fields. -/
+def captureArgs (constructor : NormalizedBlockCtor) :
+    List (((gen.rulePattern constructor).toPattern).RHS) :=
+  ((Pattern.varNPaths (.const (gen.ruleRecName constructor))
+      (gen.ruleMajorArity constructor)).take
+    (source.nparams + gen.familyCount + gen.minorCount)).map
+      (fun path => .var (.inl path)) ++
+  ((Pattern.varNPaths (.const constructor.ctor.raw.name)
+      (gen.ruleArgArity constructor)).drop source.nparams).map
+      (fun path => .var (.inr path))
+
+/-- The RHS template of one rule: the registered right tower applied to the
+captured common arguments and fields. -/
+def ruleRHS (hcl : gen.RuleClosure) {i : Nat} {constructor : NormalizedBlockCtor}
+    (h : gen.flatCtors[i]? = some constructor) :
+    ((gen.rulePattern constructor).toPattern).RHS :=
+  Pattern.RHS.appN (.fixed ((gen.rule i constructor).rhs) (hcl.rhs_closed h))
+    (gen.captureArgs constructor)
+
+/-- The check list of one rule: the major premise's parameters must agree
+with the recursor side's parameters, and the recursor side's index arguments
+must agree with the constructor's computed result indices (as fixed index
+towers applied to the captures). -/
+def ruleCheck (hcl : gen.RuleClosure) {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ gen.flatCtors) :
+    ((gen.rulePattern constructor).toPattern).Check :=
+  let recPaths := Pattern.varNPaths (.const (gen.ruleRecName constructor))
+    (gen.ruleMajorArity constructor)
+  let ctorPaths := Pattern.varNPaths (.const constructor.ctor.raw.name)
+    (gen.ruleArgArity constructor)
+  let common := source.nparams + gen.familyCount + gen.minorCount
+  let idxChecks :=
+    ((gen.ruleIdx constructor).attach.zip (recPaths.drop common)).foldr
+      (fun ep rest =>
+        .defeq (.var (.inl ep.2))
+          (Pattern.RHS.appN
+            (.fixed (VExpr.lamN (gen.ruleBinders constructor) ep.1.1)
+              (hcl.idxTower_closed hc ep.1.1 ep.1.2))
+            (gen.captureArgs constructor)) rest)
+      .true
+  ((ctorPaths.take source.nparams).zip (recPaths.take source.nparams)).foldr
+    (fun pr rest => .defeq (.var (.inr pr.1)) (.var (.inl pr.2)) rest)
+    idxChecks
+
+/-- Position `i` of the certified block's flattened constructor list. -/
+abbrev ruleEntry (i : Nat) (constructor : NormalizedBlockCtor) : Prop :=
+  gen.flatCtors[i]? = some constructor
+
+/-- A decidable sufficient condition for `RuleClosure`, discharging concrete
+fixtures by evaluation. -/
+theorem RuleClosure.of_all
+    (h1 : gen.flatCtors.zipIdx.all (fun ic =>
+      decide (((gen.rule ic.2 ic.1).rhs).ClosedN 0)) = true)
+    (h2 : gen.flatCtors.all (fun c => (gen.ruleIdx c).all fun e =>
+      decide ((VExpr.lamN (gen.ruleBinders c) e).ClosedN 0)) = true) :
+    gen.RuleClosure := by
+  constructor
+  · intro i constructor h
+    have hmem : (constructor, i) ∈ gen.flatCtors.zipIdx := by
+      apply List.mem_of_getElem? (i := i)
+      rw [List.getElem?_zipIdx, h, Option.map_some, Nat.zero_add]
+    exact of_decide_eq_true (List.all_eq_true.1 h1 _ hmem)
+  · intro constructor hc e he
+    exact of_decide_eq_true (List.all_eq_true.1 (List.all_eq_true.1 h2 _ hc) _ he)
+
+/-- The pattern set of one certified block: each flattened constructor's
+rule pattern with its template and checks. -/
+inductive IotaPat (hcl : gen.RuleClosure) :
+    (p : Pattern) → p.RHS × p.Check → Prop where
+  | mk {i : Nat} {constructor : NormalizedBlockCtor}
+      (h : gen.ruleEntry i constructor) :
+      IotaPat hcl ((gen.rulePattern constructor).toPattern)
+        (gen.ruleRHS hcl h, gen.ruleCheck hcl (List.mem_of_getElem? h))
+
+/-! ## The `Params` obligations for one certified block -/
+
+/-- `Params.pat_simple` for the block's pattern set. -/
+theorem IotaPat.pat_simple {hcl : gen.RuleClosure} {p : Pattern}
+    {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) :
+    ∃ sp : SimplePattern, p = sp.toPattern := by
+  cases H with | mk h => exact ⟨_, rfl⟩
+
+/-- Rule recovery: a pattern in the block's set determines its flattened
+rule position and constructor. -/
+theorem IotaPat.recover {hcl : gen.RuleClosure} {p : Pattern}
+    {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) :
+    ∃ (i : Nat) (constructor : NormalizedBlockCtor),
+      gen.flatCtors[i]? = some constructor ∧
+      p = (gen.rulePattern constructor).toPattern ∧
+      ∀ (i' : Nat) (constructor' : NormalizedBlockCtor),
+        gen.flatCtors[i']? = some constructor' →
+        (gen.rulePattern constructor').toPattern = p →
+        i' = i ∧ constructor' = constructor := by
+  cases H with | @mk i constructor h =>
+  refine ⟨i, constructor, h, rfl, ?_⟩
+  intro i' constructor' h' heq
+  have := RecursorIotaPattern.inj heq
+  exact gen.flatCtors_name_inj h' h this.2.2.1
+
+/-- `Params.pat_uniq` for the block's pattern set. -/
+theorem IotaPat.pat_uniq {hcl : gen.RuleClosure} {p₁ p₂ p₃ p₄ : Pattern}
+    {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check}
+    (H1 : gen.IotaPat hcl p₁ r) (H2 : gen.IotaPat hcl p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by
+  cases H1 with | @mk i c h =>
+  cases H2 with | @mk i' c' h' =>
+  rcases RecursorIotaPattern.subpattern_inv H3 with rfl | ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩
+  · obtain ⟨hR, hM, hC, hN, rfl⟩ := RecursorIotaPattern.inter_some H4
+    obtain ⟨rfl, rfl⟩ := gen.flatCtors_name_inj h' h hC
+    exact ⟨rfl, rfl, HEq.rfl⟩
+  · obtain ⟨hb, hj'⟩ := RecursorIotaPattern.inter_varN_const_some H4
+    obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? h)
+      (List.mem_of_getElem? h') hb
+    have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by
+      rw [gen.ruleMajorArity_eq (List.mem_of_getElem? h'),
+        gen.ruleMajorArity_eq (List.mem_of_getElem? h), hIdx]
+    omega
+  · obtain ⟨hb, -⟩ := RecursorIotaPattern.inter_varN_const_some H4
+    obtain ⟨t', family', ht', ho', -, -, -⟩ :=
+      gen.flatCtors_anatomy (List.mem_of_getElem? h')
+    have hrec : gen.ruleRecName c' = (.str family'.raw.name "rec" : Name) := by
+      rw [ruleRecName, ho', gen.familyNameAt_eq ht']
+    refine absurd ?_ (gen.recName_ne_ctorName (List.mem_of_getElem? ht')
+      (List.mem_of_getElem? h))
+    rw [← hrec, hb]
+
+/-- `Params.pat_app_l` for the block's pattern set. -/
+theorem IotaPat.pat_app_l {hcl : gen.RuleClosure} {p : Pattern}
+    {r : p.RHS × p.Check} {p₁ p₂ p₃ p₄ : Pattern}
+    (H : gen.IotaPat hcl p r) (h : Subpattern (.app p₁ p₂) p) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  cases H with | @mk i c hi =>
+  obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+  intro hsub
+  obtain ⟨j', hj', heq'⟩ := hsub.varN_const_le
+  cases j' <;> exact absurd heq' (by simp [Pattern.varN])
+
+/-- `Params.pat_app_l_uniq` for the block's pattern set. -/
+theorem IotaPat.pat_app_l_uniq {hcl : gen.RuleClosure} {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check} {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases H with | @mk i c hi =>
+  cases H' with | @mk i' c' hi' =>
+  obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+  obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h'
+  obtain ⟨j, hj, heq⟩ := h₃.varN_const_le
+  cases j with
+  | zero => exact absurd heq (by simp [Pattern.varN])
+  | succ j'' =>
+    rw [show Pattern.varN (.const (gen.ruleRecName c)) (j'' + 1) =
+        .var (Pattern.varN (.const (gen.ruleRecName c)) j'') from rfl] at heq
+    injection heq with heq'
+    subst heq'
+    by_cases hname : gen.ruleRecName c' = gen.ruleRecName c
+    · obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? hi')
+        (List.mem_of_getElem? hi) hname
+      have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by
+        rw [gen.ruleMajorArity_eq (List.mem_of_getElem? hi'),
+          gen.ruleMajorArity_eq (List.mem_of_getElem? hi), hIdx]
+      rw [hname]
+      exact Pattern.varN_const_inter_of_ne_arity (by omega) _ _
+    · exact Pattern.varN_const_inter_of_ne_name hname _ _
+
+/-- `Params.pat_app_uniq` for the block's pattern set. -/
+theorem IotaPat.pat_app_uniq {hcl : gen.RuleClosure} {p p' : Pattern}
+    {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') : p₃.inter p₃' = none := by
+  cases H with | @mk i c hi =>
+  cases H' with | @mk i' c' hi' =>
+  obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+  obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h'
+  obtain ⟨j, hj, rfl⟩ := h₃.varN_const_le
+  obtain ⟨j', hj', rfl⟩ := h₃'.varN_const_le
+  refine Pattern.varN_const_inter_of_ne_name ?_ _ _
+  obtain ⟨t, family, ht, ho, -, -, -⟩ :=
+    gen.flatCtors_anatomy (List.mem_of_getElem? hi)
+  have hrec : gen.ruleRecName c = (.str family.raw.name "rec" : Name) := by
+    rw [ruleRecName, ho, gen.familyNameAt_eq ht]
+  rw [hrec]
+  exact gen.recName_ne_ctorName (List.mem_of_getElem? ht)
+    (List.mem_of_getElem? hi')
+
+/-! ## Axiom closures of the generic pattern facts -/
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.ruleLhsBody_matches' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms ruleLhsBody_matches
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.view_resultIndices_length' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms view_resultIndices_length
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.rulePattern_inj' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms rulePattern_inj
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_simple' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms IotaPat.pat_simple
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.recover' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms IotaPat.recover
+
+/--
+info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms IotaPat.pat_uniq
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms IotaPat.pat_app_l
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms IotaPat.pat_app_l_uniq
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms IotaPat.pat_app_uniq
+
+end BlockGenerationChecked
+
+end VInductDecl
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/Typing/InductivePatternEnv.lean b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean
new file mode 100644
index 00000000..78676bd2
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean
@@ -0,0 +1,902 @@
+import Lean4Lean.Theory.Typing.InductivePatternWF
+
+/-! # The block-local pattern environment assembler
+
+`assembleEnv` builds an environment whose defeq set consists of exactly one
+certified block's generated iota rules plus separately certified extension
+rules over a defeq-free constant base. The exposed helpers are the ones
+Church–Rosser instantiation and downstream consumers need:
+
+* `assembleEnv_defeqs` inverts the assembled defeq set exactly: a registered
+  defeq is a generated rule, an extension, or a base defeq — nothing else.
+* `assembleEnv_WF` preserves ordering through the block phases and the
+  extension fold, given the block's semantic package and each extension's
+  well-formedness.
+* `AssembledPat` is the union pattern set. The block half carries the full
+  L4L-10A obligations and `pat_wf`; the extension half carries each
+  certificate's own pattern payload. `CertifiedExtension.covers` records
+  the match at the beta-collapsed body of a registered lambda tower, never
+  at the closed tower itself. No open-environment `Params` instance is
+  installed. -/
+
+namespace Lean4Lean
+
+namespace VExpr
+
+/-- Remove the leading lambda tower from an expression.  This is the
+syntactic point at which first-order reduction patterns are matched; a
+closed lambda tower itself is deliberately not a `Pattern`. -/
+def stripLams : VExpr → VExpr
+  | .lam _ body => stripLams body
+  | e => e
+
+@[simp] theorem stripLams_lamN (binders : List VExpr) (body : VExpr) :
+    stripLams (lamN binders body) = stripLams body := by
+  induction binders with
+  | nil => rfl
+  | cons _ binders ih => exact ih
+
+/-- Universe instantiation commutes with exposing the body of a lambda
+tower. -/
+theorem stripLams_instL (e : VExpr) (ls : List VLevel) :
+    stripLams (e.instL ls) = (stripLams e).instL ls := by
+  induction e with
+  | lam _ _ _ ih => exact ih
+  | _ => rfl
+
+end VExpr
+
+/-! ## Pattern shape helpers and head separation
+
+Side-condition-free shape facts about `Pattern.inter`, `Subpattern`, and
+constant towers, followed by the head inventory of a `SimplePattern` and the
+two separation predicates the union-level non-overlap laws consume.
+`HeadSep.inter_subpattern_none` is the cross-term engine: under head
+separation one simple pattern's pattern intersects no subpattern of the
+other's.  `HeadSep.app_l_uniq` and `HeadSep.app_uniq` are its two `app`-level
+companions, exported because a fixture whose `Params` spans several blocks
+must discharge its cross-block cases from them by hand. -/
+
+namespace Pattern
+
+/-- An application pattern never meets a bare constant. -/
+theorem app_inter_const {f a : Pattern} {c : Name} :
+    (Pattern.app f a).inter (.const c) = none := rfl
+
+/-- A bare constant never meets an application pattern. -/
+theorem const_inter_app {f a : Pattern} {c : Name} :
+    (Pattern.const c).inter (.app f a) = none := rfl
+
+/-- A bare constant never meets a `.var` pattern. -/
+theorem const_inter_var {f : Pattern} {c : Name} :
+    (Pattern.const c).inter (.var f) = none := rfl
+
+/-- Distinct bare constants never meet. -/
+theorem const_inter_const_of_ne {c c' : Name} (h : c ≠ c') :
+    (Pattern.const c).inter (.const c') = none := by
+  simp [Pattern.inter, h]
+
+/-- A bare constant meets a constant tower only at height zero with the
+same name. -/
+theorem const_inter_varN_of_ne {c c' : Name} (h : c ≠ c') :
+    ∀ j, (Pattern.const c).inter (Pattern.varN (.const c') j) = none
+  | 0 => const_inter_const_of_ne h
+  | _+1 => const_inter_var
+
+end Pattern
+
+/-- The only subpattern of a bare constant pattern is itself. -/
+theorem Subpattern.const_inv {p : Pattern} {c : Name}
+    (H : Subpattern p (.const c)) : p = .const c := by
+  cases H; rfl
+
+/-- A `.var`-shaped subpattern of a constant tower is a strictly shorter
+tower. -/
+theorem Subpattern.var_varN_const_le {c : Name} {M : Nat} {q : Pattern}
+    (h : Subpattern (.var q) (Pattern.varN (.const c) M)) :
+    ∃ j, j + 1 ≤ M ∧ q = Pattern.varN (.const c) j := by
+  obtain ⟨j, hj, heq⟩ := h.varN_const_le
+  cases j with
+  | zero => exact absurd heq (by simp [Pattern.varN])
+  | succ j'' =>
+    rw [show Pattern.varN (.const c) (j'' + 1) =
+        .var (Pattern.varN (.const c) j'') from rfl] at heq
+    injection heq with heq'
+    exact ⟨j'', hj, heq'⟩
+
+namespace SimplePattern
+
+/-- The defined-symbol head of a simple pattern: the unfolded constant of a
+`defn` rule, the recursor of an `iota` rule. -/
+def symbHead : SimplePattern → Name
+  | .defn h => h
+  | .iota r _ _ _ => r
+
+/-- The constructor head of an `iota` rule's major premise. -/
+def ctorHead? : SimplePattern → Option Name
+  | .defn _ => none
+  | .iota _ _ c _ => some c
+
+@[simp] theorem symbHead_defn {h : Name} : symbHead (.defn h) = h := rfl
+@[simp] theorem symbHead_iota {r c : Name} {m n : Nat} :
+    symbHead (.iota r m c n) = r := rfl
+@[simp] theorem ctorHead?_defn {h : Name} : ctorHead? (.defn h) = none := rfl
+@[simp] theorem ctorHead?_iota {r c : Name} {m n : Nat} :
+    ctorHead? (.iota r m c n) = some c := rfl
+
+/-- Internal head-distinctness of one simple pattern: an `iota` rule's
+recursor head is not its constructor head.  Block rules get this from
+`recName_ne_ctorName`; a certified extension must supply it. -/
+def SelfSeparated : SimplePattern → Prop
+  | .defn _ => True
+  | .iota r _ c _ => r ≠ c
+
+/-- Head separation between two simple patterns: symb heads differ, and
+each side's symb head differs from the other side's constructor head.
+Constructor-vs-constructor collisions are deliberately NOT excluded — they
+never produce an intersection. -/
+structure HeadSep (sp sp' : SimplePattern) : Prop where
+  symb_ne_symb : sp.symbHead ≠ sp'.symbHead
+  symb_ne_ctor : ∀ c' ∈ sp'.ctorHead?, sp.symbHead ≠ c'
+  ctor_ne_symb : ∀ c ∈ sp.ctorHead?, c ≠ sp'.symbHead
+
+/-- Head separation is symmetric. -/
+theorem HeadSep.symm {sp sp' : SimplePattern} (h : HeadSep sp sp') :
+    HeadSep sp' sp where
+  symb_ne_symb := h.symb_ne_symb.symm
+  symb_ne_ctor := fun c hc => (h.ctor_ne_symb c hc).symm
+  ctor_ne_symb := fun c' hc' => (h.symb_ne_ctor c' hc').symm
+
+/-- Constructor form for two iota patterns from the three required name
+disequalities. -/
+theorem HeadSep.iota_iota {r c r' c' : Name} {m n m' n' : Nat}
+    (h1 : r ≠ r') (h2 : r ≠ c') (h3 : c ≠ r') :
+    HeadSep (.iota r m c n) (.iota r' m' c' n') where
+  symb_ne_symb := h1
+  symb_ne_ctor := fun x hx => by cases hx; exact h2
+  ctor_ne_symb := fun x hx => by cases hx; exact h3
+
+/-- The cross-term engine: under head separation, `sp'`'s pattern
+intersects NO subpattern of `sp`'s pattern.  This is the single new
+combinatorial fact the union-level laws need. -/
+theorem HeadSep.inter_subpattern_none {sp sp' : SimplePattern}
+    (hsep : sp.HeadSep sp') {p₃ : Pattern}
+    (hsub : Subpattern p₃ sp.toPattern) :
+    sp'.toPattern.inter p₃ = none := by
+  cases sp with
+  | defn h =>
+    obtain rfl := Subpattern.const_inv hsub
+    cases sp' with
+    | defn h' => exact Pattern.const_inter_const_of_ne hsep.symb_ne_symb.symm
+    | iota r' m' c' n' => exact Pattern.app_inter_const
+  | iota r m c n =>
+    have hcs : c ≠ sp'.symbHead := hsep.ctor_ne_symb c rfl
+    rcases RecursorIotaPattern.subpattern_inv hsub with
+      rfl | ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩
+    · -- p₃ is the whole iota pattern
+      cases sp' with
+      | defn h' => exact Pattern.const_inter_app
+      | iota r' m' c' n' =>
+        cases e : (SimplePattern.iota r' m' c' n').toPattern.inter
+            (RecursorIotaPattern r m c n) with
+        | none => rfl
+        | some q =>
+          exact absurd (RecursorIotaPattern.inter_some e).1.symm
+            hsep.symb_ne_symb
+    · -- p₃ is a tower of the recursor head r
+      cases sp' with
+      | defn h' =>
+        exact Pattern.const_inter_varN_of_ne hsep.symb_ne_symb.symm j
+      | iota r' m' c' n' =>
+        cases e : (SimplePattern.iota r' m' c' n').toPattern.inter
+            (Pattern.varN (.const r) j) with
+        | none => rfl
+        | some q =>
+          exact absurd (RecursorIotaPattern.inter_varN_const_some e).1
+            hsep.symb_ne_symb
+    · -- p₃ is a tower of the constructor head c
+      cases sp' with
+      | defn h' => exact Pattern.const_inter_varN_of_ne hcs.symm j
+      | iota r' m' c' n' =>
+        cases e : (SimplePattern.iota r' m' c' n').toPattern.inter
+            (Pattern.varN (.const c) j) with
+        | none => rfl
+        | some q =>
+          exact absurd (RecursorIotaPattern.inter_varN_const_some e).1 hcs
+
+/-- Self-overlap engine: any self-intersecting subpattern of a
+self-separated simple pattern is the whole pattern. -/
+theorem SelfSeparated.subpattern_inter_eq {sp : SimplePattern}
+    (hself : sp.SelfSeparated) {p₃ p₄ : Pattern}
+    (hsub : Subpattern p₃ sp.toPattern)
+    (hint : sp.toPattern.inter p₃ = some p₄) :
+    p₃ = sp.toPattern := by
+  cases sp with
+  | defn h => exact Subpattern.const_inv hsub
+  | iota r m c n =>
+    rcases RecursorIotaPattern.subpattern_inv hsub with
+      rfl | ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩
+    · rfl
+    · obtain ⟨-, h2⟩ := RecursorIotaPattern.inter_varN_const_some hint
+      exact absurd h2 (by omega)
+    · exact absurd (RecursorIotaPattern.inter_varN_const_some hint).1.symm
+        hself
+
+/-- `pat_app_l` is side-condition-free for ANY simple pattern. -/
+theorem toPattern_app_l {sp : SimplePattern} {p₁ p₂ p₃ p₄ : Pattern}
+    (h : Subpattern (.app p₁ p₂) sp.toPattern) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  cases sp with
+  | defn head =>
+    intro _
+    exact absurd (Subpattern.const_inv h) (by simp)
+  | iota r m c n =>
+    obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+    intro hsub
+    obtain ⟨j', -, heq'⟩ := hsub.varN_const_le
+    cases j' <;> exact absurd heq' (by simp [Pattern.varN])
+
+/-- The `pat_app_l_uniq` shape fact for two head-separated simple patterns:
+`sp'`'s left spine never meets a `.var` subpattern of `sp`'s left spine,
+because head separation keeps the two recursor towers' names apart.  The
+union law `AssembledPat.pat_app_l_uniq` is this lemma at every mixed pair;
+a `Params` spanning several blocks calls it directly for the cross-block
+pairs. -/
+theorem HeadSep.app_l_uniq {sp sp' : SimplePattern}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern} (hsep : sp.HeadSep sp')
+    (h : Subpattern (.app p₁ p₂) sp.toPattern)
+    (h' : Subpattern (.app p₁' p₂') sp'.toPattern)
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases sp with
+  | defn head => exact absurd (Subpattern.const_inv h) (by simp)
+  | iota R M C N =>
+    obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+    obtain ⟨j, -, rfl⟩ := Subpattern.var_varN_const_le h₃
+    cases sp' with
+    | defn head' => exact absurd (Subpattern.const_inv h') (by simp)
+    | iota R' M' C' N' =>
+      obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h'
+      exact Pattern.varN_const_inter_of_ne_name hsep.symb_ne_symb.symm _ _
+
+/-- The `pat_app_uniq` shape fact for two head-separated simple patterns: a
+subpattern of `sp`'s left spine never meets a subpattern of `sp'`'s right
+spine, because head separation keeps `sp`'s symb head apart from `sp'`'s
+constructor head.  Companion of `HeadSep.app_l_uniq`, with the same role in
+`AssembledPat.pat_app_uniq` and in multi-block fixtures. -/
+theorem HeadSep.app_uniq {sp sp' : SimplePattern}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern} (hsep : sp.HeadSep sp')
+    (h : Subpattern (.app p₁ p₂) sp.toPattern)
+    (h' : Subpattern (.app p₁' p₂') sp'.toPattern)
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases sp with
+  | defn head => exact absurd (Subpattern.const_inv h) (by simp)
+  | iota R M C N =>
+    obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+    obtain ⟨j, -, rfl⟩ := h₃.varN_const_le
+    cases sp' with
+    | defn head' => exact absurd (Subpattern.const_inv h') (by simp)
+    | iota R' M' C' N' =>
+      obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h'
+      obtain ⟨j', -, rfl⟩ := h₃'.varN_const_le
+      exact Pattern.varN_const_inter_of_ne_name (hsep.symb_ne_ctor C' rfl) _ _
+
+end SimplePattern
+
+namespace VInductDecl
+
+/-- One separately certified extension rule for an assembled environment:
+its registered defeq, a simple pattern, and the pattern payload. Coverage is
+stated at `VExpr.stripLams (df.lhs.instL ls)`, the beta-collapsed pattern
+site, rather than at `df.lhs.instL ls`, which is generally a closed lambda
+tower. Check obligations and the typed equality from the matched redex to
+the RHS are discharged by the consumer at the reduction site and are
+carried by `ParRed.extra`; this certificate does not make either fact true
+by registration alone. -/
+structure CertifiedExtension where
+  df : VDefEq
+  pat : SimplePattern
+  rhs : (pat.toPattern).RHS
+  check : (pat.toPattern).Check
+  covers : ∀ (ls : List VLevel), ls.length = df.uvars →
+    ∃ m1 m2, (pat.toPattern).Matches
+      (VExpr.stripLams (df.lhs.instL ls)) m1 m2
+
+namespace CertifiedExtension
+
+/-- The first-order pattern exposed by the body of `quotDefEq`: five
+arguments to `Quot.lift`, followed by a three-argument `Quot.mk` major. -/
+def quotPattern : SimplePattern :=
+  .iota ``Quot.lift 5 ``Quot.mk 3
+
+private def quotRecPaths :=
+  Pattern.varNPaths (.const ``Quot.lift) 5
+
+private def quotCtorPaths :=
+  Pattern.varNPaths (.const ``Quot.mk) 3
+
+/-- The six arguments of the registered quotient tower: all five lift
+arguments followed by the quotient representative. -/
+def quotCaptureArgs : List (quotPattern.toPattern.RHS) :=
+  quotRecPaths.map (fun path => .var (.inl path)) ++
+    (quotCtorPaths.drop 2).map (fun path => .var (.inr path))
+
+/-- The registered right tower applied to the captures selected by the
+collapsed quotient pattern. -/
+def quotRHS : quotPattern.toPattern.RHS :=
+  Pattern.RHS.appN (.fixed quotDefEq.rhs (by decide)) quotCaptureArgs
+
+/-- The constructor-side `α` and relation arguments must agree with the
+corresponding `Quot.lift` arguments. -/
+def quotCheck : quotPattern.toPattern.Check :=
+  ((quotCtorPaths.take 2).zip (quotRecPaths.take 2)).foldr
+    (fun paths rest => .defeq (.var (.inr paths.1))
+      (.var (.inl paths.2)) rest) .true
+
+/-- Exact non-lambda body of the registered quotient equation. -/
+def quotLhsBody : VExpr :=
+  .app
+    (VExpr.appN (.const ``Quot.lift [.param 0, .param 1])
+      [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1])
+    (VExpr.appN (.const ``Quot.mk [.param 0])
+      [.bvar 5, .bvar 4, .bvar 0])
+
+theorem quotDefEq_lhsBody :
+    VExpr.stripLams quotDefEq.lhs = quotLhsBody := rfl
+
+/-- `quotDefEq` satisfies the same beta-collapsed registration contract as
+generated iota rules.  This is a kernel proof of pattern coverage, not a
+project axiom and not an operational equality oracle. -/
+def quot : CertifiedExtension where
+  df := quotDefEq
+  pat := quotPattern
+  rhs := quotRHS
+  check := quotCheck
+  covers := by
+    intro ls hlen
+    have hlen' : ls.length = 2 := by simpa [quotDefEq] using hlen
+    have hlevels : [.param 0, .param 1].map (VLevel.inst ls) = ls :=
+      VLevel.inst_map_id hlen'
+    let mkLevels := [.param 0].map (VLevel.inst ls)
+    have hleft : HeadConstN ``Quot.lift ls 5
+        (VExpr.appN (.const ``Quot.lift ls)
+          [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1]) := by
+      have h0 : HeadConstN ``Quot.lift ls 0 (.const ``Quot.lift ls) := .const
+      simpa using h0.appN
+        [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1]
+    have hright : HeadConstN ``Quot.mk mkLevels 3
+        (VExpr.appN (.const ``Quot.mk mkLevels)
+          [.bvar 5, .bvar 4, .bvar 0]) := by
+      have h0 : HeadConstN ``Quot.mk mkLevels 0 (.const ``Quot.mk mkLevels) := .const
+      simpa using h0.appN [.bvar 5, .bvar 4, .bvar 0]
+    obtain ⟨m2, hm⟩ := RecursorIotaPattern.matches_of hleft hright
+    refine ⟨ls, m2, ?_⟩
+    rw [VExpr.stripLams_instL, quotDefEq_lhsBody]
+    have hbody : quotLhsBody.instL ls =
+        .app
+          (VExpr.appN (.const ``Quot.lift ls)
+            [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1])
+          (VExpr.appN (.const ``Quot.mk mkLevels)
+            [.bvar 5, .bvar 4, .bvar 0]) := by
+      simp [quotLhsBody, VExpr.instL, VExpr.instL_appN, hlevels, mkLevels]
+    rw [hbody]
+    exact hm
+
+end CertifiedExtension
+
+namespace BlockGenerationChecked
+
+variable {source : VInductDecl} (gen : source.BlockGenerationChecked)
+
+/-- Every generated iota rule satisfies the beta-collapsed extension shape.
+The witness is derived from the generated rule body and is independent of
+the rule's semantic soundness proof (`pat_wf`). -/
+def iotaExtension (hcl : gen.RuleClosure) {i : Nat}
+    {constructor : NormalizedBlockCtor} (h : gen.ruleEntry i constructor) :
+    CertifiedExtension where
+  df := gen.rule i constructor
+  pat := gen.rulePattern constructor
+  rhs := gen.ruleRHS hcl h
+  check := gen.ruleCheck hcl (List.mem_of_getElem? h)
+  covers := by
+    intro ls hlen
+    obtain ⟨m2, hm⟩ := gen.ruleLhsBody_matches constructor
+    have hm := hm.instL ls
+    have hlevels : gen.recLevels.map (VLevel.inst ls) = ls :=
+      VLevel.inst_map_id (hlen.trans (gen.rule_uvars i constructor))
+    rw [hlevels] at hm
+    refine ⟨ls, (fun x => (m2 x).instL ls), ?_⟩
+    rw [gen.rule_lhs, VExpr.instL_lamN, VExpr.stripLams_lamN]
+    have hbody : gen.ruleLhsBody constructor =
+        .app (VExpr.appN
+          (gen.recBase (gen.ruleFieldCount constructor) constructor.owner)
+          (gen.ruleIdx constructor)) (gen.ruleCtorApp constructor) := by
+      rw [ruleLhsBody, VExpr.appN_append]
+      rfl
+    have hstrip : VExpr.stripLams ((gen.ruleLhsBody constructor).instL ls) =
+        (gen.ruleLhsBody constructor).instL ls := by
+      rw [hbody]
+      rfl
+    rw [hstrip]
+    exact hm
+
+/-- The assembled block-local environment: dependency constants from the
+base, the block's four insertion phases, and the certified extension
+defeqs. -/
+def assembleEnv (base : VEnv) (exts : List CertifiedExtension) :
+    Option VEnv := do
+  let env ← base.addInductBlockGeneration gen
+  return exts.foldl (fun env ext => env.addDefEq ext.df) env
+
+/-! ## Defeq-set inversion -/
+
+private theorem addConst_defeqs {env env' : VEnv} {n : Name} {ci : VConstant}
+    (h : env.addConst n ci = some env') {df : VDefEq} :
+    env'.defeqs df ↔ env.defeqs df := by
+  unfold VEnv.addConst at h
+  split at h
+  · cases h
+  · cases h
+    exact Iff.rfl
+
+private theorem foldlM_addConst_defeqs {α : Type _} (name : α → Name)
+    (ci : α → VConstant) :
+    ∀ (xs : List α) {env env' : VEnv},
+      xs.foldlM (fun env x => env.addConst (name x) (ci x)) env = some env' →
+      ∀ {df : VDefEq}, (env'.defeqs df ↔ env.defeqs df)
+  | [], env, env', h, df => by cases h; exact Iff.rfl
+  | x :: xs, env, env', h, df => by
+    rw [List.foldlM_cons] at h
+    rcases Option.bind_eq_some_iff.1 h with ⟨envx, hx, hrest⟩
+    exact (foldlM_addConst_defeqs name ci xs hrest).trans (addConst_defeqs hx)
+
+private theorem foldl_addDefEq_defeqs :
+    ∀ (dfs : List VDefEq) (env : VEnv) (df : VDefEq),
+      ((dfs.foldl VEnv.addDefEq env).defeqs df ↔ df ∈ dfs ∨ env.defeqs df)
+  | [], env, df => by simp
+  | d :: dfs, env, df => by
+    rw [List.foldl_cons, foldl_addDefEq_defeqs dfs (env.addDefEq d) df]
+    show _ ∨ (df = d ∨ _) ↔ _
+    rw [List.mem_cons]
+    constructor
+    · rintro (h | h | h)
+      · exact .inl (.inr h)
+      · exact .inl (.inl h)
+      · exact .inr h
+    · rintro ((h | h) | h)
+      · exact .inr (.inl h)
+      · exact .inl h
+      · exact .inr (.inr h)
+
+/-- Registered defeqs of a completed block transaction are exactly the
+generated rules over the base's. -/
+theorem addInductBlockGeneration_defeqs {base env₁ : VEnv}
+    (hadd : base.addInductBlockGeneration gen = some env₁) (df : VDefEq) :
+    env₁.defeqs df ↔ df ∈ gen.generatedRules ∨ base.defeqs df := by
+  rcases VEnv.addInductBlockGeneration_trace hadd with ⟨H⟩
+  rw [← H.addRules, foldl_addDefEq_defeqs]
+  refine or_congr Iff.rfl ?_
+  exact ((foldlM_addConst_defeqs _ _ _ H.addRecs).trans
+    ((foldlM_addConst_defeqs _ _ _ H.addCtors).trans
+      (foldlM_addConst_defeqs _ _ _ H.addTypes)))
+
+/-- The assembled defeq set, inverted exactly. -/
+theorem assembleEnv_defeqs {base env' : VEnv}
+    {exts : List CertifiedExtension}
+    (hadd : gen.assembleEnv base exts = some env') (df : VDefEq) :
+    env'.defeqs df ↔
+      df ∈ gen.generatedRules ∨ (∃ ext ∈ exts, df = ext.df) ∨
+        base.defeqs df := by
+  unfold assembleEnv at hadd
+  rcases Option.bind_eq_some_iff.1 hadd with ⟨env₁, h₁, h₂⟩
+  cases Option.some.inj h₂
+  have hfold : ∀ (es : List CertifiedExtension) (env : VEnv),
+      ((es.foldl (fun env ext => env.addDefEq ext.df) env).defeqs df ↔
+        (∃ ext ∈ es, df = ext.df) ∨ env.defeqs df) := by
+    intro es
+    induction es with
+    | nil => intro env; simp
+    | cons e es ih =>
+      intro env
+      rw [List.foldl_cons, ih (env.addDefEq e.df)]
+      show _ ∨ (df = e.df ∨ _) ↔ _
+      constructor
+      · rintro (⟨ext, hm, rfl⟩ | rfl | hbase)
+        · exact .inl ⟨ext, .tail _ hm, rfl⟩
+        · exact .inl ⟨e, .head _, rfl⟩
+        · exact .inr hbase
+      · rintro (⟨ext, hm, rfl⟩ | hbase)
+        · rcases List.mem_cons.1 hm with rfl | hm
+          · exact .inr (.inl rfl)
+          · exact .inl ⟨ext, hm, rfl⟩
+        · exact .inr (.inr hbase)
+  rw [hfold, gen.addInductBlockGeneration_defeqs h₁]
+  constructor
+  · rintro (h | h | h)
+    · exact .inr (.inl h)
+    · exact .inl h
+    · exact .inr (.inr h)
+  · rintro (h | h | h)
+    · exact .inr (.inl h)
+    · exact .inl h
+    · exact .inr (.inr h)
+
+/-- A defeq-free base makes the assembled defeq set exactly the generated
+rules plus the certified extensions. -/
+theorem assembleEnv_defeq_cases {base env' : VEnv}
+    {exts : List CertifiedExtension}
+    (hadd : gen.assembleEnv base exts = some env')
+    (hbase : ∀ df, ¬base.defeqs df) {df : VDefEq}
+    (hdf : env'.defeqs df) :
+    df ∈ gen.generatedRules ∨ ∃ ext ∈ exts, df = ext.df := by
+  rcases (gen.assembleEnv_defeqs hadd df).1 hdf with h | h | h
+  · exact .inl h
+  · exact .inr h
+  · exact absurd h (hbase df)
+
+/-! ## Ordering -/
+
+/-- The assembled environment is ordered: the block transaction preserves
+ordering through its four phases, and each certified extension is well
+formed over the post-block environment. -/
+theorem assembleEnv_WF {base : VEnv} (henv : base.Ordered)
+    {blockEnv : VEnv} (hgen : gen.WF base blockEnv)
+    {exts : List CertifiedExtension} {env₁ : VEnv}
+    (hadd₁ : base.addInductBlockGeneration gen = some env₁)
+    (hexts : ∀ ext ∈ exts, ext.df.WF env₁) :
+    ∃ env', gen.assembleEnv base exts = some env' ∧ env'.Ordered := by
+  refine ⟨exts.foldl (fun env ext => env.addDefEq ext.df) env₁, ?_, ?_⟩
+  · unfold assembleEnv
+    rw [hadd₁]
+    rfl
+  · have hord₁ : env₁.Ordered :=
+      VEnv.addInductBlockGeneration_WF henv hgen hadd₁
+    have hmap : exts.foldl (fun env ext => env.addDefEq ext.df) env₁ =
+        (exts.map (·.df)).foldl VEnv.addDefEq env₁ := by
+      rw [List.foldl_map]
+    rw [hmap]
+    exact VInductDecl.rulesFold_WF _ hord₁
+      (fun df hdf => by
+        rcases List.mem_map.1 hdf with ⟨ext, hm, rfl⟩
+        exact hexts ext hm)
+
+/-! ## The union pattern set -/
+
+/-- The assembled pattern set: the block's iota patterns with their L4L-10A
+payloads, plus each certified extension's pattern payload. -/
+inductive AssembledPat (hcl : gen.RuleClosure)
+    (exts : List CertifiedExtension) :
+    (p : Pattern) → p.RHS × p.Check → Prop where
+  | rule {p : Pattern} {r : p.RHS × p.Check} :
+      gen.IotaPat hcl p r → AssembledPat hcl exts p r
+  | ext (ext : CertifiedExtension) (hmem : ext ∈ exts) :
+      AssembledPat hcl exts (ext.pat.toPattern) (ext.rhs, ext.check)
+
+/-- `Params.pat_simple` for the assembled set. -/
+theorem AssembledPat.pat_simple {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} {p : Pattern} {r : p.RHS × p.Check}
+    (H : gen.AssembledPat hcl exts p r) :
+    ∃ sp : SimplePattern, p = sp.toPattern := by
+  cases H with
+  | rule h => exact h.pat_simple
+  | ext ext hmem => exact ⟨ext.pat, rfl⟩
+
+/-- Inversion for the assembled set, the `AssembledPat` counterpart of
+`IotaPat.recover`: an assembled pattern is either a block rule at a
+recoverable flattened position or one of the certified extensions, with its
+payload recovered up to `HEq` in both cases.  A consumer needs this because
+`cases` cannot destructure `AssembledPat` at a *concrete* iota pattern —
+the block half's index `(gen.rulePattern constructor).toPattern` is a stuck
+`varN` tower, so dependent elimination fails — whereas this lemma's
+conclusion is index-free and applies at any `p`. -/
+theorem AssembledPat.recover {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} {p : Pattern} {r : p.RHS × p.Check}
+    (H : gen.AssembledPat hcl exts p r) :
+    (∃ (i : Nat) (constructor : NormalizedBlockCtor)
+        (h : gen.ruleEntry i constructor),
+        p = (gen.rulePattern constructor).toPattern ∧
+          r ≍ (gen.ruleRHS hcl h,
+            gen.ruleCheck hcl (List.mem_of_getElem? h))) ∨
+      (∃ ext ∈ exts, p = ext.pat.toPattern ∧ r ≍ (ext.rhs, ext.check)) := by
+  cases H with
+  | rule h =>
+    cases h with
+    | @mk i constructor hentry =>
+      exact .inl ⟨i, constructor, hentry, rfl, HEq.rfl⟩
+  | ext ext hmem => exact .inr ⟨ext, hmem, rfl, HEq.rfl⟩
+
+/-- Extension defeqs of the assembled set expose their pattern at the
+beta-collapsed body of the registered lambda tower. -/
+theorem AssembledPat.ext_covers {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} {ext : CertifiedExtension}
+    (hmem : ext ∈ exts) {ls : List VLevel} (hls : ls.length = ext.df.uvars) :
+    ∃ p r m1 m2, gen.AssembledPat hcl exts p r ∧
+      p.Matches (VExpr.stripLams (ext.df.lhs.instL ls)) m1 m2 := by
+  obtain ⟨m1, m2, hmatch⟩ := ext.covers ls hls
+  exact ⟨ext.pat.toPattern, (ext.rhs, ext.check), m1, m2,
+    .ext ext hmem, hmatch⟩
+
+/-! ## Union-level non-overlap
+
+The four block-local `IotaPat` non-overlap laws lift to the assembled
+union exactly under a head-freshness certificate for the extension list;
+`separation_is_necessary` below pins that the naive statements are
+false. -/
+
+/-- The head-freshness certificate a fixture must supply for its extension
+list.  This is the corrected hypothesis inventory: without it the union
+laws below are false (see `separation_is_necessary`). -/
+structure ExtSeparation (exts : List CertifiedExtension) : Prop where
+  self_sep : ∀ ext ∈ exts, ext.pat.SelfSeparated
+  block_sep : ∀ ext ∈ exts, ∀ ⦃constructor : NormalizedBlockCtor⦄,
+    constructor ∈ gen.flatCtors →
+      ext.pat.HeadSep (gen.rulePattern constructor)
+  ext_uniq : ∀ ext₁ ∈ exts, ∀ ext₂ ∈ exts,
+    ext₁.pat = ext₂.pat → ext₁ = ext₂
+  ext_sep : ∀ ext₁ ∈ exts, ∀ ext₂ ∈ exts,
+    ext₁.pat ≠ ext₂.pat → ext₁.pat.HeadSep ext₂.pat
+
+/-! ### Scope: one `AssembledPat` covers exactly one block
+
+`ExtSeparation.ext_sep` demands pairwise `HeadSep` between any two
+extensions with distinct patterns, and `HeadSep.symb_ne_symb` requires their
+symb heads to differ.  Two iota rules of the *same* block share a recursor
+name, so `symb_ne_symb` is false for them and no `ExtSeparation` can list
+them together: the extension list is not a place to park a second block's
+rules.  Covering a whole block at once is the job of the block half of
+`AssembledPat`, and that half is fixed to the single `gen` the certificate
+carries — every mutually inductive type of one `VInductDecl` transaction,
+and nothing else.  Intra-block non-overlap is settled by `IotaPat`'s
+constructor-name injectivity rather than by head separation, which is
+exactly why the block half needs no `HeadSep` among its own rules.
+
+So a fixture whose `Params` must range over two or more blocks does not
+enlarge one `AssembledPat`.  It takes the N-way sum of the per-block pattern
+sets — one `AssembledPat` per block, each with its own `gen`, `RuleClosure`,
+and extension list — and hand-writes the cross-block cases of the four
+non-overlap obligations, N(N-1) ordered pairs of blocks per obligation.
+Those cases are mechanical.  Reduce each side to its `SimplePattern`
+inventory (`AssembledPat.pat_simple`, plus a per-fixture lemma naming the
+finitely many patterns a block contributes), prove `HeadSep` once for every
+cross-block pair of simple patterns — `decide` on the names suffices — and
+then apply `SimplePattern.HeadSep.inter_subpattern_none` for `pat_uniq`,
+`SimplePattern.HeadSep.app_l_uniq` for `pat_app_l_uniq`, and
+`SimplePattern.HeadSep.app_uniq` for `pat_app_uniq`.  `pat_app_l` needs no
+separation at all: it follows from `pat_simple` and
+`SimplePattern.toPattern_app_l` uniformly across blocks. -/
+
+/-- `Params.pat_uniq` for the assembled union, under `ExtSeparation`; the
+(rule, rule) case delegates to `IotaPat.pat_uniq`. -/
+theorem AssembledPat.pat_uniq {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} (hsep : gen.ExtSeparation exts)
+    {p₁ p₂ p₃ p₄ : Pattern} {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check}
+    (H1 : gen.AssembledPat hcl exts p₁ r)
+    (H2 : gen.AssembledPat hcl exts p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by
+  cases H1 with
+  | rule h1 =>
+    cases H2 with
+    | rule h2 => exact IotaPat.pat_uniq gen h1 h2 H3 H4
+    | ext ext2 hm2 =>
+      cases h1 with | @mk i c hentry =>
+      rw [((hsep.block_sep ext2 hm2
+        (List.mem_of_getElem? hentry)).symm).inter_subpattern_none H3] at H4
+      cases H4
+  | ext ext1 hm1 =>
+    cases H2 with
+    | rule h2 =>
+      cases h2 with | @mk i c hentry =>
+      rw [(hsep.block_sep ext1 hm1
+        (List.mem_of_getElem? hentry)).inter_subpattern_none H3] at H4
+      cases H4
+    | ext ext2 hm2 =>
+      rcases Classical.em (ext1.pat = ext2.pat) with hpq | hpq
+      · obtain rfl := hsep.ext_uniq ext1 hm1 ext2 hm2 hpq
+        exact ⟨rfl,
+          ((hsep.self_sep ext1 hm1).subpattern_inter_eq H3 H4).symm, HEq.rfl⟩
+      · rw [(hsep.ext_sep ext1 hm1 ext2 hm2 hpq).inter_subpattern_none H3]
+          at H4
+        cases H4
+
+/-- `Params.pat_app_l` for the assembled union — no separation needed:
+every assembled pattern is simple, and simple patterns are `app`-flat on
+the left. -/
+theorem AssembledPat.pat_app_l {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension}
+    {p : Pattern} {r : p.RHS × p.Check} {p₁ p₂ p₃ p₄ : Pattern}
+    (H : gen.AssembledPat hcl exts p r) (h : Subpattern (.app p₁ p₂) p) :
+    ¬Subpattern (.app p₃ p₄) p₁ := by
+  obtain ⟨sp, rfl⟩ := H.pat_simple
+  exact SimplePattern.toPattern_app_l h
+
+/-- `Params.pat_app_l_uniq` for the assembled union, under
+`ExtSeparation`; the (rule, rule) case delegates to
+`IotaPat.pat_app_l_uniq`. -/
+theorem AssembledPat.pat_app_l_uniq {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} (hsep : gen.ExtSeparation exts)
+    {p p' : Pattern} {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : gen.AssembledPat hcl exts p r)
+    (H' : gen.AssembledPat hcl exts p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by
+  cases H with
+  | rule h1 =>
+    cases H' with
+    | rule h2 => exact IotaPat.pat_app_l_uniq gen h1 h2 h h' h₃
+    | ext ext2 hm2 =>
+      cases h1 with | @mk i c hentry =>
+      exact ((hsep.block_sep ext2 hm2
+        (List.mem_of_getElem? hentry)).symm).app_l_uniq h h' h₃
+  | ext ext1 hm1 =>
+    cases H' with
+    | rule h2 =>
+      cases h2 with | @mk i c hentry =>
+      exact (hsep.block_sep ext1 hm1
+        (List.mem_of_getElem? hentry)).app_l_uniq h h' h₃
+    | ext ext2 hm2 =>
+      rcases Classical.em (ext1.pat = ext2.pat) with hpq | hpq
+      · -- Equal patterns: separation cannot apply, but the two towers then
+        -- differ in arity, `h₃` being a strictly shorter left spine.
+        cases hsp1 : ext1.pat with
+        | defn hd =>
+          rw [hsp1] at h
+          exact absurd (Subpattern.const_inv h) (by simp)
+        | iota R1 M1 C1 N1 =>
+          rw [hsp1] at h
+          obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+          obtain ⟨j, hj, rfl⟩ := Subpattern.var_varN_const_le h₃
+          rw [← hpq, hsp1] at h'
+          obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h'
+          exact Pattern.varN_const_inter_of_ne_arity (by omega) _ _
+      · exact (hsep.ext_sep ext1 hm1 ext2 hm2 hpq).app_l_uniq h h' h₃
+
+/-- `Params.pat_app_uniq` for the assembled union, under `ExtSeparation`;
+the (rule, rule) case delegates to `IotaPat.pat_app_uniq`. -/
+theorem AssembledPat.pat_app_uniq {hcl : gen.RuleClosure}
+    {exts : List CertifiedExtension} (hsep : gen.ExtSeparation exts)
+    {p p' : Pattern} {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : gen.AssembledPat hcl exts p r)
+    (H' : gen.AssembledPat hcl exts p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none := by
+  cases H with
+  | rule h1 =>
+    cases H' with
+    | rule h2 => exact IotaPat.pat_app_uniq gen h1 h2 h h' h₃ h₃'
+    | ext ext2 hm2 =>
+      cases h1 with | @mk i c hentry =>
+      exact ((hsep.block_sep ext2 hm2
+        (List.mem_of_getElem? hentry)).symm).app_uniq h h' h₃ h₃'
+  | ext ext1 hm1 =>
+    cases H' with
+    | rule h2 =>
+      cases h2 with | @mk i c hentry =>
+      exact (hsep.block_sep ext1 hm1
+        (List.mem_of_getElem? hentry)).app_uniq h h' h₃ h₃'
+    | ext ext2 hm2 =>
+      rcases Classical.em (ext1.pat = ext2.pat) with hpq | hpq
+      · -- Equal patterns: separation cannot apply, but `SelfSeparated` keeps
+        -- the shared pattern's own two heads apart.
+        cases hsp1 : ext1.pat with
+        | defn hd =>
+          rw [hsp1] at h
+          exact absurd (Subpattern.const_inv h) (by simp)
+        | iota R1 M1 C1 N1 =>
+          rw [hsp1] at h
+          obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h
+          obtain ⟨j, -, rfl⟩ := h₃.varN_const_le
+          rw [← hpq, hsp1] at h'
+          obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h'
+          obtain ⟨j', -, rfl⟩ := h₃'.varN_const_le
+          have hself := hsep.self_sep ext1 hm1
+          rw [hsp1] at hself
+          exact Pattern.varN_const_inter_of_ne_name hself _ _
+      · exact (hsep.ext_sep ext1 hm1 ext2 hm2 hpq).app_uniq h h' h₃ h₃'
+
+end BlockGenerationChecked
+
+end VInductDecl
+
+/-! ## Necessity of the separation hypotheses
+
+If a defn extension's head equals a block rule's recursor name `R`, the
+extension's bare-constant pattern intersects the height-0 subtower of the
+rule pattern while the two patterns differ — so the naive union `pat_uniq`
+(whose conclusion forces the patterns equal) is false.  The same collision
+breaks the naive statement for any head in the block inventory. -/
+
+/-- Refutes the certificate-free union `pat_uniq`: a `defn` extension named
+after a rule's recursor meets a proper subpattern of the rule pattern while
+the two patterns differ. -/
+theorem separation_is_necessary (R C : Name) :
+    Subpattern (.const R) ((SimplePattern.iota R 6 C 3).toPattern) ∧
+      ((SimplePattern.defn R).toPattern).inter (.const R) =
+        some (.const R) ∧
+      (SimplePattern.iota R 6 C 3).toPattern ≠
+        (SimplePattern.defn R).toPattern := by
+  refine ⟨Subpattern.appL (Subpattern.varN .refl), by simp [Pattern.inter],
+    fun h => absurd h (by simp [SimplePattern.toPattern])⟩
+
+end Lean4Lean
+
+/-! ## Axiom closures -/
+
+/-- info: 'Lean4Lean.Pattern.Matches.instL' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.Pattern.Matches.instL
+
+/-- info: 'Lean4Lean.VInductDecl.CertifiedExtension.quot' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.CertifiedExtension.quot
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.iotaExtension' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.iotaExtension
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.recover' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.recover
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers
+
+/-- info: 'Lean4Lean.SimplePattern.HeadSep.inter_subpattern_none' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.SimplePattern.HeadSep.inter_subpattern_none
+
+/-- info: 'Lean4Lean.SimplePattern.HeadSep.app_l_uniq' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.SimplePattern.HeadSep.app_l_uniq
+
+/-- info: 'Lean4Lean.SimplePattern.HeadSep.app_uniq' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.SimplePattern.HeadSep.app_uniq
+
+/--
+info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_uniq' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_uniq
+
+/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_l' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_l
+
+/--
+info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_l_uniq' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_l_uniq
+
+/--
+info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_uniq' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_app_uniq
+
+/-- info: 'Lean4Lean.separation_is_necessary' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.separation_is_necessary
diff --git a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean
new file mode 100644
index 00000000..768b282d
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean
@@ -0,0 +1,287 @@
+import Lean4Lean.Theory.Typing.InductivePatternEnv
+
+/-! # Pattern facts for concrete certified blocks
+
+Two self-contained certified blocks pin the L4L-10A pattern layer by
+evaluation: a mutual tree/forest pair (two families, three flattened
+constructors, recursion in both directions) and an indexed vector (one
+family, a `Nat` index, indices spelled with `Nat.zero`/`Nat.succ`). Both
+use literal names throughout, keeping every closedness and inventory bit
+kernel-decidable. The expected `SimplePattern` inventories are written by
+hand: the major arity counts shared parameters, all motives, all minors, and
+the constructor's result indices; the argument arity counts the
+constructor's parameters and fields. -/
+
+namespace Lean4Lean.InductivePatternFixtures
+
+open Lean4Lean.VInductDecl
+open Lean4Lean.VInductDecl.BlockGenerationChecked
+
+deriving instance DecidableEq for SimplePattern
+
+/-- `mutual inductive PatTree (α : Type u) | node : α → PatForest α → PatTree α
+inductive PatForest (α : Type u) | nil | cons : PatTree α → PatForest α →
+PatForest α end` -/
+def patBlock : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := `PatTree
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const `PatForest [.param 0]) (.bvar 1))
+                 (.app (.const `PatTree [.param 0]) (.bvar 2))))⟩,
+           `PatTree.node⟩] },
+     { name := `PatForest
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.app (.const `PatForest [.param 0]) (.bvar 0))⟩,
+           `PatForest.nil⟩,
+          ⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.app (.const `PatTree [.param 0]) (.bvar 0))
+               (.forallE (.app (.const `PatForest [.param 0]) (.bvar 1))
+                 (.app (.const `PatForest [.param 0]) (.bvar 2))))⟩,
+           `PatForest.cons⟩] }]
+
+/-- `inductive PatVec (α : Type) : Nat → Type | nil : PatVec α Nat.zero
+| cons : α → (n : Nat) → PatVec α n → PatVec α (Nat.succ n)` -/
+def patVec : VInductDecl where
+  uvars := 0
+  nparams := 1
+  types :=
+    [{ name := `PatVec
+       uvars := 0
+       type := .forallE (.sort (.succ .zero))
+         (.forallE (.const `Nat []) (.sort (.succ .zero)))
+       ctors :=
+         [⟨⟨0, .forallE (.sort (.succ .zero))
+             (.app (.app (.const `PatVec []) (.bvar 0))
+               (.const `Nat.zero []))⟩,
+           `PatVec.nil⟩,
+          ⟨⟨0, .forallE (.sort (.succ .zero))
+             (.forallE (.bvar 0)
+               (.forallE (.const `Nat [])
+                 (.forallE (.app (.app (.const `PatVec []) (.bvar 2)) (.bvar 0))
+                   (.app (.app (.const `PatVec []) (.bvar 3))
+                     (.app (.const `Nat.succ []) (.bvar 1))))))⟩,
+           `PatVec.cons⟩] }]
+
+#guard patBlock.stage3
+#guard patVec.stage3
+
+/-- The certified mutual block. -/
+def patTreeGen : patBlock.BlockGenerationChecked :=
+  (identityBlockGeneration? patBlock).get (by decide)
+
+/-- The certified indexed block. -/
+def patVecGen : patVec.BlockGenerationChecked :=
+  (identityBlockGeneration? patVec).get (by decide)
+
+/-! ## Pattern inventories
+
+Majors: `PatTree`/`PatForest` share one parameter, two motives, and three
+minors with no indices (major arity 6); `PatVec` has one parameter, one
+motive, two minors, and one index (major arity 5). -/
+
+#guard patTreeGen.flatCtors.map (fun c => patTreeGen.rulePattern c) ==
+  [.iota (.str `PatTree "rec") 6 `PatTree.node 3,
+   .iota (.str `PatForest "rec") 6 `PatForest.nil 1,
+   .iota (.str `PatForest "rec") 6 `PatForest.cons 3]
+
+#guard patVecGen.flatCtors.map (fun c => patVecGen.rulePattern c) ==
+  [.iota (.str `PatVec "rec") 5 `PatVec.nil 1,
+   .iota (.str `PatVec "rec") 5 `PatVec.cons 4]
+
+/-! ## Payload closedness by evaluation -/
+
+theorem patTreeClosure : patTreeGen.RuleClosure :=
+  RuleClosure.of_all _ (by decide) (by decide)
+
+theorem patVecClosure : patVecGen.RuleClosure :=
+  RuleClosure.of_all _ (by decide) (by decide)
+
+/-! ## Beta-collapsed tower certificates
+
+The concrete generated block and the built-in quotient equation both expose
+their first-order match only after stripping the registered lambda tower.
+These examples pin that contract without constructing a `Params` instance or
+assuming an equality from pattern membership. -/
+
+/-- Every registered iota rule of the concrete mutual block has a
+beta-collapsed pattern witness. -/
+theorem patTreeIotaExtension_covers {i : Nat}
+    {constructor : NormalizedBlockCtor} (hentry : patTreeGen.ruleEntry i constructor)
+    (ls : List VLevel) (hlen : ls.length = (patTreeGen.rule i constructor).uvars) :
+    ∃ m1 m2, (patTreeGen.rulePattern constructor).toPattern.Matches
+      (VExpr.stripLams ((patTreeGen.rule i constructor).lhs.instL ls)) m1 m2 :=
+  (patTreeGen.iotaExtension patTreeClosure hentry).covers ls hlen
+
+/-- `quotDefEq` satisfies the same beta-collapsed coverage contract. -/
+theorem quotDefEq_covers (ls : List VLevel)
+    (hlen : ls.length = quotDefEq.uvars) :
+    ∃ m1 m2, CertifiedExtension.quotPattern.toPattern.Matches
+      (VExpr.stripLams (quotDefEq.lhs.instL ls)) m1 m2 :=
+  CertifiedExtension.quot.covers ls hlen
+
+/-!
+The tower witnesses stay on the standard logical baseline. In particular,
+neither closure contains a project axiom or `sorryAx`.
+-/
+
+/--
+info: 'Lean4Lean.InductivePatternFixtures.patTreeIotaExtension_covers' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms patTreeIotaExtension_covers
+
+/-- info: 'Lean4Lean.InductivePatternFixtures.quotDefEq_covers' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms quotDefEq_covers
+
+/-! ## The instantiated pattern sets
+
+Both blocks now carry complete pattern payloads: `patTreeGen.IotaPat
+patTreeClosure` and `patVecGen.IotaPat patVecClosure` satisfy every generic
+obligation proved in `Theory/Typing/InductivePattern.lean`, at the standard
+axiom closure recorded below. -/
+
+/-- info: 'Lean4Lean.InductivePatternFixtures.patTreeClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms patTreeClosure
+
+/-- info: 'Lean4Lean.InductivePatternFixtures.patVecClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms patVecClosure
+
+/-! ## The assembled block-local environments
+
+Both blocks assemble over the empty base with no extensions; their defeq
+sets are exactly their generated rules. -/
+
+#guard (patTreeGen.assembleEnv .empty []).isSome
+#guard (patVecGen.assembleEnv .empty []).isSome
+
+/-- Every defeq of the assembled tree/forest environment is a generated
+rule: the base is defeq-free and no extensions are registered. -/
+example {env' : VEnv} (h : patTreeGen.assembleEnv .empty [] = some env')
+    {df : VDefEq} (hdf : env'.defeqs df) :
+    df ∈ patTreeGen.generatedRules := by
+  rcases patTreeGen.assembleEnv_defeq_cases h (fun _ hd => hd) hdf with
+    hrule | ⟨ext, hm, -⟩
+  · exact hrule
+  · cases hm
+
+/-! ## Union-level non-overlap: the mutual block plus the quotient extension
+
+The union-level laws of `Theory/Typing/InductivePatternEnv.lean` require an
+`ExtSeparation` certificate for the extension list.  For the concrete
+mutual tree/forest block extended with `CertifiedExtension.quot` the
+certificate is kernel-decidable: the rule inventory is pinned by `decide`
+and every required head disequality is a literal name comparison.  All four
+union laws instantiate below. -/
+
+/-- The three-rule inventory of the mutual tree/forest block,
+kernel-checked (the `Prop` form of the `#guard` inventory above). -/
+theorem patTree_rulePattern_inventory :
+    patTreeGen.flatCtors.map (fun c => patTreeGen.rulePattern c) =
+      [.iota (.str `PatTree "rec") 6 `PatTree.node 3,
+       .iota (.str `PatForest "rec") 6 `PatForest.nil 1,
+       .iota (.str `PatForest "rec") 6 `PatForest.cons 3] := by decide
+
+/-- Head separation of the quotient extension from every rule of the
+mutual block. -/
+theorem quot_headSep_patTree {constructor : NormalizedBlockCtor}
+    (hc : constructor ∈ patTreeGen.flatCtors) :
+    (CertifiedExtension.quot.pat).HeadSep
+      (patTreeGen.rulePattern constructor) := by
+  have hp : patTreeGen.rulePattern constructor ∈
+      patTreeGen.flatCtors.map (fun c => patTreeGen.rulePattern c) :=
+    List.mem_map_of_mem hc
+  rw [patTree_rulePattern_inventory] at hp
+  have hq : CertifiedExtension.quot.pat =
+      .iota ``Quot.lift 5 ``Quot.mk 3 := rfl
+  simp only [List.mem_cons, List.not_mem_nil, or_false] at hp
+  rcases hp with hp | hp | hp <;> rw [hq, hp] <;>
+    exact SimplePattern.HeadSep.iota_iota (by decide) (by decide) (by decide)
+
+/-- The complete separation certificate for the mutual block unioned with
+the quotient extension, discharged by kernel `decide`. -/
+theorem patTree_quot_separation :
+    patTreeGen.ExtSeparation [CertifiedExtension.quot] := by
+  refine ⟨?_, ?_, ?_, ?_⟩
+  · rintro ext hm
+    rw [List.mem_singleton] at hm
+    subst hm
+    show (``Quot.lift : Name) ≠ ``Quot.mk
+    decide
+  · rintro ext hm c hc
+    rw [List.mem_singleton] at hm
+    subst hm
+    exact quot_headSep_patTree hc
+  · rintro e1 h1 e2 h2 -
+    rw [List.mem_singleton] at h1 h2
+    subst h1; subst h2; rfl
+  · rintro e1 h1 e2 h2 hne
+    rw [List.mem_singleton] at h1 h2
+    subst h1; subst h2
+    exact absurd rfl hne
+
+/-- All four union laws instantiate for the two-inductive mutual block with
+the quotient extension. -/
+example {p₁ p₂ p₃ p₄ : Pattern} {r : p₁.RHS × p₁.Check}
+    {r' : p₂.RHS × p₂.Check}
+    (H1 : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p₁ r)
+    (H2 : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p₂ r')
+    (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) :
+    p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' :=
+  AssembledPat.pat_uniq patTreeGen patTree_quot_separation H1 H2 H3 H4
+
+example {p : Pattern} {r : p.RHS × p.Check} {p₁ p₂ p₃ p₄ : Pattern}
+    (H : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p r)
+    (h : Subpattern (.app p₁ p₂) p) : ¬Subpattern (.app p₃ p₄) p₁ :=
+  AssembledPat.pat_app_l patTreeGen H h
+
+example {p p' : Pattern} {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ : Pattern}
+    (H : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p r)
+    (H' : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none :=
+  AssembledPat.pat_app_l_uniq patTreeGen patTree_quot_separation
+    H H' h h' h₃
+
+example {p p' : Pattern} {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check}
+    {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern}
+    (H : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p r)
+    (H' : patTreeGen.AssembledPat patTreeClosure [CertifiedExtension.quot]
+      p' r')
+    (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p')
+    (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') :
+    p₃.inter p₃' = none :=
+  AssembledPat.pat_app_uniq patTreeGen patTree_quot_separation
+    H H' h h' h₃ h₃'
+
+/-!
+The separation certificate stays on the standard logical baseline; in
+particular it contains no project axiom and no `sorryAx`, and its `decide`
+steps are kernel-checked.
+-/
+
+/-- info: 'Lean4Lean.InductivePatternFixtures.patTree_quot_separation' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms patTree_quot_separation
+
+end Lean4Lean.InductivePatternFixtures
diff --git a/Lean4Lean/Theory/Typing/InductivePatternWF.lean b/Lean4Lean/Theory/Typing/InductivePatternWF.lean
new file mode 100644
index 00000000..48ec3f00
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean
@@ -0,0 +1,949 @@
+import Lean4Lean.Theory.Typing.InductivePattern
+import Lean4Lean.Theory.Typing.UniqueTyping
+
+/-! # Pattern soundness for generated iota rules
+
+The typed β-collapse layer for L4L-10B: applying a lambda tower to a
+well-typed argument spine is definitionally equal to the iterated
+instantiation of its body (`IsDefEq.appN_lamN`), applications are
+congruent along spines (`IsDefEq.appN_congr`, `IsDefEq.appN_defEq` over
+`SpineDefEq`), and a matched pattern's captures are exactly the spine
+arguments (`varN_matches_paths`). `pat_wf` then proves that a successful
+match whose checks hold is definitionally equal to its RHS template — by
+applying the registered `addInduct` rule tower to the captured arguments
+and β-collapsing both readings. -/
+
+namespace Lean4Lean
+
+open VExpr
+
+namespace VExpr
+
+/-- Instantiation pushes under a lambda telescope, mirroring
+`instN_forallN`. -/
+theorem instN_lamN (a : VExpr) : ∀ (tel : List VExpr) (X : VExpr) (k : Nat),
+    (lamN tel X).inst a k = lamN (instTelN a tel k) (X.inst a (k + tel.length))
+  | [], _, _ => rfl
+  | A :: tel, X, k => by
+    show VExpr.lam _ _ = VExpr.lam _ _
+    rw [instN_lamN a tel X (k+1),
+      show k+1+tel.length = k+(tel.length+1) from by omega]
+    rfl
+
+/-- Universe instantiation pushes under a lambda telescope. -/
+theorem instL_lamN (ls : List VLevel) : ∀ (As : List VExpr) (e : VExpr),
+    (lamN As e).instL ls = lamN (As.map (instL ls)) (e.instL ls)
+  | [], _ => rfl
+  | A :: As, e => by
+    show VExpr.lam _ _ = VExpr.lam _ _
+    rw [instL_lamN ls As e]
+
+end VExpr
+
+/-- Matching a constant `varN` tower captures exactly the spine arguments:
+the `varNPaths` read back the argument list. -/
+theorem Pattern.varN_matches_paths {c : Name} {m1 : List VLevel} :
+    ∀ (n : Nat) (as : List VExpr) {f : VExpr} {m2},
+      (Pattern.varN (.const c) n).Matches (VExpr.appN f as) m1 m2 →
+      as.length = n →
+      (Pattern.varNPaths (.const c) n).map m2 = as := by
+  intro n
+  induction n with
+  | zero =>
+    intro as f m2 H hlen
+    obtain rfl : as = [] := List.length_eq_zero_iff.1 hlen
+    rfl
+  | succ n ih =>
+    intro as f m2 H hlen
+    have hne : as ≠ [] := by rintro rfl; simp at hlen
+    obtain ⟨as', a, rfl⟩ : ∃ as' a, as = as' ++ [a] :=
+      ⟨as.dropLast, as.getLast hne, (List.dropLast_concat_getLast hne).symm⟩
+    rw [VExpr.appN_append] at H
+    have has : as'.length = n := by simpa using hlen
+    cases H with
+    | var h =>
+      show ((Pattern.varNPaths (.const c) n).map some ++ [none]).map _ =
+        as' ++ [a]
+      rw [List.map_append, List.map_map]
+      exact congrArg (· ++ [a]) (ih as' h has)
+
+/-- Applying an RHS template spine computes to the applied template
+values. -/
+theorem Pattern.RHS.appN_apply {p : Pattern} (m1 : List VLevel)
+    (m2 : p.Path → VExpr) :
+    ∀ (f : p.RHS) (as : List (p.RHS)),
+      (Pattern.RHS.appN f as).apply m1 m2 =
+        VExpr.appN (f.apply m1 m2) (as.map (Pattern.RHS.apply m1 m2))
+  | _, [] => rfl
+  | f, a :: as => by
+    show (Pattern.RHS.appN (.app f a) as).apply m1 m2 = _
+    rw [Pattern.RHS.appN_apply m1 m2 (.app f a) as]
+    rfl
+
+/-- A `HeadConstN` spine names its argument list. -/
+theorem HeadConstN.exists_appN {c : Name} {ls : List VLevel} :
+    ∀ {n : Nat} {e : VExpr}, HeadConstN c ls n e →
+      ∃ as : List VExpr, e = VExpr.appN (.const c ls) as ∧ as.length = n
+  | _, _, .const => ⟨[], rfl, rfl⟩
+  | _, _, .app (a := a) h =>
+    let ⟨as, he, hl⟩ := h.exists_appN
+    ⟨as ++ [a], by rw [VExpr.appN_append, ← he]; rfl, by simp [hl]⟩
+
+namespace VExpr
+
+/-- The value of a bound variable under iterated instantiation: the spine
+argument at its reverse position. -/
+theorem instRev_bvar_lt : ∀ (es : List VExpr) {i : Nat} (h : i < es.length),
+    instRev (.bvar i) es = es[es.length - 1 - i]'(by omega)
+  | e :: es, i, h => by
+    rcases Nat.lt_or_ge i es.length with h' | h'
+    · rw [show instRev (.bvar i) (e :: es) = instRev (.bvar i) es from
+        instRev_bvar_lt_cons es e h', instRev_bvar_lt es h']
+      simp only [show (e :: es).length - 1 - i = (es.length - 1 - i) + 1 from by
+        simp only [List.length_cons]; omega, List.getElem_cons_succ]
+    · obtain rfl : i = es.length := by
+        simp only [List.length_cons] at h; omega
+      show instRev (instVar es.length e es.length) es = _
+      rw [show instVar es.length e es.length = liftN es.length e from by
+        simp [instVar]]
+      rw [instRev_liftN_len]
+      simp only [show (e :: es).length - 1 - es.length = 0 from by
+        simp only [List.length_cons]; omega, List.getElem_cons_zero]
+
+/-- Iterated instantiation of a reverse bound-variable segment reads back
+the corresponding spine segment. -/
+theorem map_instRev_bvarRevRange_seg (es : List VExpr) :
+    ∀ (q off : Nat), off + q ≤ es.length →
+    (bvarRevRange off q).map (instRev · es) =
+      (es.drop (es.length - off - q)).take q := by
+  intro q
+  induction q with
+  | zero => intro off h; simp [VExpr.bvarRevRange]
+  | succ q ih =>
+    intro off h
+    show instRev (.bvar (off + q)) es :: (bvarRevRange off q).map (instRev · es) = _
+    rw [instRev_bvar_lt es (by omega), ih off (by omega)]
+    have hd : es.length - off - (q + 1) < es.length := by omega
+    simp only [show es.length - 1 - (off + q) = es.length - off - (q + 1) from by
+      omega, show es.length - off - q = (es.length - off - (q + 1)) + 1 from by
+      omega]
+    rw [List.drop_eq_getElem_cons hd, List.take_succ_cons]
+
+end VExpr
+
+/-! ## Typed β-collapse of applied telescopes -/
+
+/-- Instantiating below a reversed telescope, mirroring
+`Ctx.LiftN.consTel`. -/
+theorem Ctx.InstN.consTel {Γ₀ : List VExpr} {e₀ A₀ : VExpr} :
+    ∀ (As : List VExpr) {k : Nat} {Γ Γ' : List VExpr},
+      Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' →
+      Ctx.InstN Γ₀ e₀ A₀ (As.length + k) (As.reverse ++ Γ)
+        ((VExpr.instTelN e₀ As k).reverse ++ Γ')
+  | [], k, Γ, Γ', W => by simpa [VExpr.instTelN] using W
+  | A :: As, k, Γ, Γ', W => by
+    have h := Ctx.InstN.consTel As (Ctx.InstN.succ (A := A) W)
+    rw [show As.length + (k+1) = (A :: As).length + k from by simp; omega] at h
+    simpa [VExpr.instTelN, List.append_assoc] using h
+
+/-- Instantiating a telescope's context. -/
+theorem VEnv.OnTel.instN {env : VEnv} (henv : env.Ordered) {U : Nat}
+    {Γ₀ : List VExpr} {e₀ A₀ : VExpr} (h₀ : env.HasType U Γ₀ e₀ A₀) :
+    ∀ {As : List VExpr} {k : Nat} {Γ Γ' : List VExpr},
+      Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → VEnv.OnTel env U Γ As →
+      VEnv.OnTel env U Γ' (VExpr.instTelN e₀ As k)
+  | [], _, _, _, _, _ => trivial
+  | _ :: _, _, _, _, W, ⟨⟨u, hA⟩, hT⟩ =>
+    ⟨⟨u, hA.instN henv W h₀⟩, VEnv.OnTel.instN henv h₀ W.succ hT⟩
+
+/-- Pointwise defeq of two application spines against a peeled pi type. -/
+inductive VEnv.SpineDefEq (env : VEnv) (U : Nat) (Γ : List VExpr) :
+    VExpr → List VExpr → List VExpr → VExpr → Prop where
+  | nil : VEnv.SpineDefEq env U Γ A [] [] A
+  | cons : env.IsDefEq U Γ a a' A₁ →
+      VEnv.SpineDefEq env U Γ (A₂.inst a) es es' B →
+      VEnv.SpineDefEq env U Γ (.forallE A₁ A₂) (a :: es) (a' :: es') B
+
+/-- Iterated application congruence along a pointwise defeq spine. -/
+theorem VEnv.IsDefEq.appN_defEq {env : VEnv} {U : Nat} {Γ : List VExpr} :
+    ∀ {es es' : List VExpr} {F B X Y : VExpr},
+      env.IsDefEq U Γ X Y F → VEnv.SpineDefEq env U Γ F es es' B →
+      env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es') B
+  | [], _, _, _, _, _, h, .nil => h
+  | a :: _, a' :: _, _, _, X, Y, h, .cons ha hrest =>
+    VEnv.IsDefEq.appN_defEq (X := X.app a) (Y := Y.app a') (h.appDF ha) hrest
+
+/-- A well-typed spine is a reflexive defeq spine. -/
+theorem VEnv.SpineWF.toSpineDefEq {env : VEnv} {U : Nat} {Γ : List VExpr} :
+    ∀ {es : List VExpr} {F B : VExpr}, env.SpineWF U Γ F es B →
+      VEnv.SpineDefEq env U Γ F es es B
+  | [], _, _, .nil => .nil
+  | _ :: _, _, _, .cons ha hrest => .cons ha hrest.toSpineDefEq
+
+/-- Iterated application congruence in the function position. -/
+theorem VEnv.IsDefEq.appN_congr {env : VEnv} {U : Nat} {Γ : List VExpr}
+    {es : List VExpr} {F B X Y : VExpr}
+    (h : env.IsDefEq U Γ X Y F) (hs : env.SpineWF U Γ F es B) :
+    env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es) B :=
+  h.appN_defEq hs.toSpineDefEq
+
+/-- A registered equation remains available after environment growth.
+
+This is the primitive transport operation for consumer-certified extension
+rules: `VEnv.LE` transports registration, while the core `.extra` constructor
+still requires the exact universe instantiation side conditions. -/
+theorem VEnv.LE.extra {env env' : VEnv} (henv : env ≤ env') {U : Nat}
+    {Γ : List VExpr} {df : VDefEq} {ls : List VLevel}
+    (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF U)
+    (hlevelsLength : ls.length = df.uvars) :
+    env'.IsDefEq U Γ (df.lhs.instL ls) (df.rhs.instL ls)
+      (df.type.instL ls) :=
+  .extra (henv.defeqs hreg) hlevels hlevelsLength
+
+/-- Transport a registered equation through environment growth and then
+apply it to a well-typed spine. This is the beta-tower consumer boundary:
+registration supplies only the tower equality; application congruence and
+spine typing remain explicit proof obligations. -/
+theorem VEnv.LE.extra_appN {env env' : VEnv} (henv : env ≤ env') {U : Nat}
+    {Γ : List VExpr} {df : VDefEq} {ls : List VLevel} {args : List VExpr}
+    {B : VExpr} (hreg : env.defeqs df)
+    (hlevels : ∀ l ∈ ls, l.WF U) (hlevelsLength : ls.length = df.uvars)
+    (hspine : env.SpineWF U Γ (df.type.instL ls) args B) :
+    env'.IsDefEq U Γ
+      (VExpr.appN (df.lhs.instL ls) args)
+      (VExpr.appN (df.rhs.instL ls) args) B :=
+  (henv.extra hreg hlevels hlevelsLength).appN_congr (hspine.mono henv)
+
+/-- The symmetric applied transport is derived, not a second trusted
+extension direction. -/
+theorem VEnv.LE.extra_appN_symm {env env' : VEnv} (henv : env ≤ env')
+    {U : Nat} {Γ : List VExpr} {df : VDefEq} {ls : List VLevel}
+    {args : List VExpr} {B : VExpr} (hreg : env.defeqs df)
+    (hlevels : ∀ l ∈ ls, l.WF U) (hlevelsLength : ls.length = df.uvars)
+    (hspine : env.SpineWF U Γ (df.type.instL ls) args B) :
+    env'.IsDefEq U Γ
+      (VExpr.appN (df.rhs.instL ls) args)
+      (VExpr.appN (df.lhs.instL ls) args) B :=
+  (henv.extra_appN hreg hlevels hlevelsLength hspine).symm
+
+/-- Applying a lambda telescope to a full well-typed spine collapses to the
+iterated instantiation of its body. -/
+theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} :
+    ∀ {As : List VExpr} {Γ : List VExpr} {body T B : VExpr} {es : List VExpr},
+      VEnv.OnTel env U Γ As →
+      env.HasType U (As.reverse ++ Γ) body T →
+      env.SpineWF U Γ (VExpr.forallN As T) es B →
+      es.length = As.length →
+      env.IsDefEq U Γ (VExpr.appN (VExpr.lamN As body) es)
+        (VExpr.instRev body es) B
+  | [], Γ, body, T, B, es, _, hb, hs, hlen => by
+    obtain rfl : es = [] := List.length_eq_zero_iff.1 hlen
+    obtain rfl : T = B := hs.nil_inv
+    exact hb
+  | A :: As, Γ, body, T, B, e :: es, ⟨⟨u, hA⟩, hT⟩, hb,
+      .cons he hrest, hlen => by
+    have hb' : env.HasType U (As.reverse ++ (A :: Γ)) body T := by
+      simpa [List.append_assoc] using hb
+    have hlam : env.HasType U (A :: Γ) (VExpr.lamN As body)
+        (VExpr.forallN As T) := VEnv.HasType.lamN hT hb'
+    have hbeta := VEnv.IsDefEq.beta hlam he
+    rw [VExpr.instN_lamN, Nat.zero_add] at hbeta
+    have hlen2 : es.length = As.length := by simpa using hlen
+    have hT' : VEnv.OnTel env U Γ (VExpr.instTelN e As 0) :=
+      VEnv.OnTel.instN henv he .zero hT
+    have hb'' : env.HasType U ((VExpr.instTelN e As 0).reverse ++ Γ)
+        (body.inst e As.length) (T.inst e As.length) := by
+      have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero
+      have := hb'.instN henv W he
+      simpa using this
+    have hrest' : env.SpineWF U Γ
+        (VExpr.forallN (VExpr.instTelN e As 0) (T.inst e As.length)) es B := by
+      rw [VExpr.instN_forallN] at hrest
+      simpa using hrest
+    have hlen' : es.length = (VExpr.instTelN e As 0).length := by
+      rw [VExpr.instTelN_length]; exact hlen2
+    have IH := VEnv.IsDefEq.appN_lamN henv hT' hb'' hrest' hlen'
+    have hstep := VEnv.IsDefEq.appN_congr hbeta hrest
+    show env.IsDefEq U Γ
+      (VExpr.appN ((VExpr.lam A (VExpr.lamN As body)).app e) es)
+      (VExpr.instRev (body.inst e es.length) es) B
+    rw [hlen2]
+    exact hstep.trans IH
+
+/-- Instantiate a terminal definitional equality through a saturated telescope spine. -/
+theorem VEnv.SpineWF.instRev_defeq
+    {env : VEnv} (henv : env.Ordered) {U : Nat} {Γ : List VExpr} :
+    ∀ {As : List VExpr} {C C' T : VExpr} {es : List VExpr} {B : VExpr},
+      env.SpineWF U Γ (VExpr.forallN As C) es B →
+      es.length = As.length →
+      env.IsDefEq U (As.reverse ++ Γ) C C' T →
+      env.IsDefEq U Γ (VExpr.instRev C es) (VExpr.instRev C' es)
+        (VExpr.instRev T es)
+  | [], C, C', T, [], B, hspine, _, hterminal => by
+      simpa [VExpr.instRev] using hterminal
+  | [], _, _, _, _ :: _, _, _, hlen, _ => by simp at hlen
+  | _ :: _, _, _, _, [], _, _, hlen, _ => by simp at hlen
+  | A :: As, C, C', T, e :: es, B,
+      .cons he hrest, hlen, hterminal => by
+      have hlen' : es.length = As.length := by simpa using hlen
+      have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero
+      have hterminal₀ : env.IsDefEq U (As.reverse ++ A :: Γ) C C' T := by
+        simpa [List.reverse_cons, List.append_assoc] using hterminal
+      have hterminal' := hterminal₀.instN henv he W
+      have hrest' : env.SpineWF U Γ
+          (VExpr.forallN (VExpr.instTelN e As 0)
+            (C.inst e As.length)) es B := by
+        rw [VExpr.instN_forallN] at hrest
+        simpa using hrest
+      have hout := VEnv.SpineWF.instRev_defeq henv hrest'
+        (by simpa [VExpr.instTelN_length] using hlen') hterminal'
+      simpa [VExpr.instRev, hlen'] using hout
+
+/-- Iterated inversion of a lambda tower's typing: the telescope is
+well-formed and the body is typed under it. -/
+theorem VEnv.HasType.lamN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) :
+    ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr},
+      OnCtx Γ (env.IsType U) →
+      env.HasType U Γ (VExpr.lamN As body) V →
+      VEnv.OnTel env U Γ As ∧
+        ∃ T₀, env.HasType U (As.reverse ++ Γ) body T₀
+  | [], Γ, body, V, _, H => ⟨trivial, V, H⟩
+  | A :: As, Γ, body, V, hΓ, H => by
+    obtain ⟨⟨u, hA⟩, W, hrest⟩ := VEnv.HasType.lam_inv henv hΓ H
+    obtain ⟨hT, T₀, hbody⟩ :=
+      VEnv.HasType.lamN_wf henv (As := As) (Γ := A :: Γ) ⟨hΓ, u, hA⟩ hrest
+    exact ⟨⟨⟨u, hA⟩, hT⟩, T₀, by simpa [List.append_assoc] using hbody⟩
+
+/-- The levels of a `HeadConstN` spine are unique. -/
+theorem HeadConstN.levels_uniq {c : Name} :
+    ∀ {n : Nat} {e : VExpr} {ls ls' : List VLevel},
+      HeadConstN c ls n e → HeadConstN c ls' n e → ls = ls'
+  | _, _, _, _, .const, .const => rfl
+  | _, _, _, _, .app h, .app h' => h.levels_uniq h'
+
+/-- Zip a well-typed spine with pointwise defeqs into a defeq spine.
+Reflexive entries need no defeq evidence. -/
+theorem VEnv.SpineWF.defEq_of_pointwise {env : VEnv} (henv : env.WF)
+    {U : Nat} {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) :
+    ∀ {es es' : List VExpr} {F B : VExpr},
+      env.SpineWF U Γ F es B →
+      List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU U Γ a a') es es' →
+      VEnv.SpineDefEq env U Γ F es es' B
+  | [], [], _, _, .nil, .nil => .nil
+  | _ :: _, _ :: _, _, _, .cons he hrest, .cons hd htl => by
+    refine .cons ?_ (hrest.defEq_of_pointwise henv hΓ htl)
+    rcases hd with rfl | hd
+    · exact he
+    · exact VEnv.IsDefEqU.of_l henv hΓ hd he
+
+/-- Unfold the `OK` predicate through a folded list of defeq checks. -/
+theorem Pattern.Check.OK.of_foldr {p : Pattern} {α : Type _}
+    {df : VExpr → VExpr → Prop} {m1 : List VLevel} {m2 : p.Path → VExpr}
+    (f g : α → p.RHS) :
+    ∀ {xs : List α} {rest : p.Check},
+      ((xs.foldr (fun x acc => Pattern.Check.defeq (f x) (g x) acc)
+        rest).OK df m1 m2) →
+      (∀ x ∈ xs, df ((f x).apply m1 m2) ((g x).apply m1 m2)) ∧
+        rest.OK df m1 m2
+  | [], _, h => ⟨nofun, h⟩
+  | _ :: xs, rest, h => by
+    obtain ⟨h1, h2⟩ := h
+    obtain ⟨h3, h4⟩ := Pattern.Check.OK.of_foldr f g (xs := xs) h2
+    refine ⟨fun x hx => ?_, h4⟩
+    rcases List.mem_cons.1 hx with rfl | hx
+    · exact h1
+    · exact h3 x hx
+
+/-- Build a pointwise relation between two mapped lists from their zip. -/
+private theorem forall₂_zip_map {α β : Type _} (F : α → VExpr) (G : β → VExpr)
+    (R : VExpr → VExpr → Prop) :
+    ∀ (xs : List α) (ys : List β), xs.length = ys.length →
+      (∀ p ∈ xs.zip ys, R (F p.1) (G p.2)) →
+      List.Forall₂ R (xs.map F) (ys.map G)
+  | [], [], _, _ => .nil
+  | x :: xs, y :: ys, hlen, hall =>
+    .cons (hall (x, y) (.head _))
+      (forall₂_zip_map F G R xs ys (by simpa using hlen)
+        fun p hp => hall p (.tail _ hp))
+  | [], _ :: _, hlen, _ => by simp at hlen
+  | _ :: _, [], hlen, _ => by simp at hlen
+
+/-- Universe instantiation fixes a reverse bound-variable range. -/
+theorem VExpr.bvarRevRange_map_instL (ls : List VLevel) :
+    ∀ (off m : Nat),
+      (VExpr.bvarRevRange off m).map (VExpr.instL ls) =
+        VExpr.bvarRevRange off m
+  | _, 0 => rfl
+  | off, m+1 => by
+    simp only [VExpr.bvarRevRange, List.map_cons, VExpr.instL,
+      VExpr.bvarRevRange_map_instL ls off m]
+
+/-- A well-formed telescope extends a well-formed context. -/
+theorem VEnv.OnTel.onCtx {env : VEnv} {U : Nat} :
+    ∀ {As Γ : List VExpr}, OnCtx Γ (env.IsType U) →
+      VEnv.OnTel env U Γ As → OnCtx (As.reverse ++ Γ) (env.IsType U)
+  | [], _, hΓ, _ => hΓ
+  | A :: As, Γ, hΓ, ⟨hA, hT⟩ => by
+    simpa [List.append_assoc] using
+      VEnv.OnTel.onCtx (As := As) (Γ := A :: Γ) ⟨hΓ, hA⟩ hT
+
+/-- Every argument of a well-typed application spine is well-typed. -/
+theorem VEnv.HasType.appN_args_wf {env : VEnv} (henv : env.WF) {U : Nat}
+    {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) :
+    ∀ (n : Nat) (es : List VExpr), es.length = n → ∀ {f B : VExpr},
+      env.HasType U Γ (VExpr.appN f es) B →
+      ∀ e ∈ es, ∃ T, env.HasType U Γ e T := by
+  intro n
+  induction n with
+  | zero =>
+    intro es hlen f B H e he
+    obtain rfl := List.length_eq_zero_iff.1 hlen
+    cases he
+  | succ n ih =>
+    intro es hlen f B H e he
+    have hne : es ≠ [] := by rintro rfl; simp at hlen
+    obtain ⟨es', a, rfl⟩ : ∃ es' a, es = es' ++ [a] :=
+      ⟨es.dropLast, es.getLast hne, (List.dropLast_concat_getLast hne).symm⟩
+    rw [VExpr.appN_append] at H
+    have H' : env.HasType U Γ ((VExpr.appN f es').app a) B := H
+    obtain ⟨A₁, B₁, hf, ha⟩ := H'.app_inv henv hΓ
+    rcases List.mem_append.1 he with he' | he'
+    · exact ih es' (by simpa using hlen) hf e he'
+    · obtain rfl : e = a := by simpa using he'
+      exact ⟨A₁, ha⟩
+
+/-- Iterated inversion of a pi tower's typing: the telescope is well formed
+and the body is typed under it. -/
+theorem VEnv.HasType.forallN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) :
+    ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr},
+      env.HasType U Γ (VExpr.forallN As body) V →
+      VEnv.OnTel env U Γ As ∧ ∃ V', env.HasType U (As.reverse ++ Γ) body V'
+  | [], _, _, V, H => ⟨trivial, V, H⟩
+  | A :: As, Γ, body, V, H => by
+    obtain ⟨⟨u, hA⟩, v, hB⟩ := VEnv.HasType.forallE_inv henv H
+    obtain ⟨hT, V', hbody⟩ := VEnv.HasType.forallN_wf henv (As := As) hB
+    exact ⟨⟨⟨u, hA⟩, hT⟩, V', by simpa [List.append_assoc] using hbody⟩
+
+private theorem forall₂_refl_or {R : VExpr → VExpr → Prop} :
+    ∀ (l : List VExpr), List.Forall₂ (fun a a' => a = a' ∨ R a a') l l
+  | [] => .nil
+  | _ :: l => .cons (Or.inl rfl) (forall₂_refl_or l)
+
+private theorem forall₂_append {R : VExpr → VExpr → Prop} :
+    ∀ {l₁ l₂ l₁' l₂' : List VExpr}, List.Forall₂ R l₁ l₂ →
+      List.Forall₂ R l₁' l₂' → List.Forall₂ R (l₁ ++ l₁') (l₂ ++ l₂')
+  | [], [], _, _, .nil, h => h
+  | _ :: _, _ :: _, _, _, .cons hd htl, h => .cons hd (forall₂_append htl h)
+
+namespace VInductDecl
+
+namespace BlockGenerationChecked
+
+variable {source : VInductDecl} (gen : source.BlockGenerationChecked)
+
+/-! ## Named shapes of one generated rule -/
+
+theorem rule_type (i : Nat) (c : NormalizedBlockCtor) :
+    (gen.rule i c).type =
+      VExpr.forallN (gen.ruleBinders c)
+        (VExpr.appN
+          (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount +
+            gen.ruleFieldCount c))
+          (gen.ruleIdx c ++ [gen.ruleCtorApp c])) := rfl
+
+theorem rule_uvars (i : Nat) (c : NormalizedBlockCtor) :
+    (gen.rule i c).uvars = gen.recUvars := rfl
+
+theorem paramsTel_length : gen.paramsTel.length = source.nparams := by
+  show ((generationParams gen.block.rawParams gen.block.checked.params).map
+    (VExpr.instL gen.sourceLevels)).length = _
+  rw [List.length_map]
+  exact (generationParams_length_of_eq gen.shape.2.1).trans gen.shape.1
+
+theorem ruleBinders_length (c : NormalizedBlockCtor) :
+    (gen.ruleBinders c).length =
+      source.nparams + gen.familyCount + gen.minorCount +
+        gen.ruleFieldCount c := by
+  simp only [ruleBinders, List.length_append, gen.paramsTel_length,
+    motiveTypes, gen.motiveTypesAux_length, minorTypes,
+    gen.minorTypesAux_length, VExpr.liftTelN_length, ruleFieldCount]
+  try omega
+
+/-- The instantiated left body as one flattened application spine. -/
+theorem ruleLhsBody_instL (c : NormalizedBlockCtor) {m1 : List VLevel}
+    (hlen1 : m1.length = gen.recUvars) :
+    (gen.ruleLhsBody c).instL m1 =
+      VExpr.appN (.const (gen.ruleRecName c) m1)
+        (VExpr.bvarRevRange (gen.ruleFieldCount c)
+            (source.nparams + gen.familyCount + gen.minorCount) ++
+          (gen.ruleIdx c).map (VExpr.instL m1) ++
+          [(gen.ruleCtorApp c).instL m1]) := by
+  show (VExpr.appN
+      (VExpr.appN (.const (gen.ruleRecName c) gen.recLevels)
+        (VExpr.bvarRevRange (gen.ruleFieldCount c)
+          (source.nparams + gen.familyCount + gen.minorCount)))
+      (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1 = _
+  rw [← VExpr.appN_append, VExpr.instL_appN]
+  show VExpr.appN (.const (gen.ruleRecName c)
+      (gen.recLevels.map (VLevel.inst m1))) _ = _
+  rw [show gen.recLevels.map (VLevel.inst m1) = m1 from
+    VLevel.inst_map_id hlen1]
+  rw [List.map_append, List.map_append, VExpr.bvarRevRange_map_instL,
+    List.append_assoc]
+  rfl
+
+/-- The instantiated major premise of the rule body. -/
+theorem ruleCtorApp_instL (c : NormalizedBlockCtor) (m1 : List VLevel) :
+    (gen.ruleCtorApp c).instL m1 =
+      VExpr.appN (.const c.ctor.raw.name
+          (gen.sourceLevels.map (VLevel.inst m1)))
+        (VExpr.bvarRevRange
+            (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount))
+            source.nparams ++
+          VExpr.bvarRevRange 0 (gen.ruleFieldCount c)) := by
+  show (VExpr.appN (.const c.ctor.raw.name gen.sourceLevels) _).instL m1 = _
+  rw [VExpr.instL_appN, List.map_append, VExpr.bvarRevRange_map_instL,
+    VExpr.bvarRevRange_map_instL]
+  rfl
+
+/-- The captured template values are exactly the shared prefix of the
+recursor spine and the field suffix of the major premise. -/
+private theorem captureArgs_apply {c : NormalizedBlockCtor} {m1 : List VLevel}
+    {g1 : Pattern.Path
+      (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c)) → VExpr}
+    {g2 : Pattern.Path
+      (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c)) → VExpr}
+    {fArgs aArgs : List VExpr}
+    (hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c))
+      (gen.ruleMajorArity c)).map g1 = fArgs)
+    (hg2 : (Pattern.varNPaths (.const c.ctor.raw.name)
+      (gen.ruleArgArity c)).map g2 = aArgs) :
+    (gen.captureArgs c).map
+      (Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1
+        (Sum.elim g1 g2)) =
+      fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        aArgs.drop source.nparams := by
+  rw [captureArgs, List.map_append, List.map_map, List.map_map]
+  show List.map g1 (List.take
+      (source.nparams + gen.familyCount + gen.minorCount)
+      (Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c))) ++
+    List.map g2 (List.drop source.nparams
+      (Pattern.varNPaths (.const c.ctor.raw.name)
+        (gen.ruleArgArity c))) = _
+  rw [List.map_take, List.map_drop, hg1, hg2]
+
+/-- Pattern soundness for one certified block (`pat_wf`): a successful match
+of a rule's pattern whose checks hold is definitionally equal to the
+instantiated RHS template, derived from the rule defeq registered by
+`addInduct` via typed β-collapse. The redex arrives decomposed into its
+recursor and constructor spines with spine-form typing, and the major
+premise's levels pinned to the rule's source levels; both are exactly what
+a verified reduction site holds. -/
+theorem pat_wf {env : VEnv} (henv : env.WF) {univs : Nat} {Γ : List VExpr}
+    (hΓ : OnCtx Γ (env.IsType univs))
+    (hcl : gen.RuleClosure)
+    {i : Nat} {c : NormalizedBlockCtor} (h : gen.ruleEntry i c)
+    (hreg : env.defeqs (gen.rule i c))
+    (hwf : (gen.rule i c).WF env)
+    {m1 : List VLevel} {m2}
+    (hm1 : ∀ l ∈ m1, l.WF univs) (hlen1 : m1.length = gen.recUvars)
+    {fArgs aArgs : List VExpr}
+    (hMlen : fArgs.length = gen.ruleMajorArity c)
+    (hNlen : aArgs.length = gen.ruleArgArity c)
+    (hm : ((gen.rulePattern c).toPattern).Matches
+      (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs)
+        (VExpr.appN (.const c.ctor.raw.name
+          (gen.sourceLevels.map (VLevel.inst m1))) aArgs)) m1 m2)
+    (hck : (gen.ruleCheck hcl (List.mem_of_getElem? h)).OK
+      (env.IsDefEqU univs Γ) m1 m2)
+    {Frec Ae : VExpr}
+    (hehead : env.HasType univs Γ (.const (gen.ruleRecName c) m1) Frec)
+    (hespine : env.SpineWF univs Γ Frec
+      (fArgs ++ [VExpr.appN (.const c.ctor.raw.name
+        (gen.sourceLevels.map (VLevel.inst m1))) aArgs]) Ae)
+    {Fctor Actor : VExpr}
+    (hctorhead : env.HasType univs Γ
+      (.const c.ctor.raw.name (gen.sourceLevels.map (VLevel.inst m1))) Fctor)
+    (hctorspine : env.SpineWF univs Γ Fctor aArgs Actor)
+    {B : VExpr}
+    (hcaps : env.SpineWF univs Γ ((gen.rule i c).type.instL m1)
+      (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        aArgs.drop source.nparams) B) :
+    env.IsDefEqU univs Γ
+      (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs)
+        (VExpr.appN (.const c.ctor.raw.name
+          (gen.sourceLevels.map (VLevel.inst m1))) aArgs))
+      ((gen.ruleRHS hcl h).apply m1 m2) := by
+  have henvo := henv.ordered
+  have hc := List.mem_of_getElem? h
+  cases hm with
+  | @app _ _ _ g1 _ _ f2 g2 h1 h2 =>
+  -- canonical captures
+  have hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c))
+      (gen.ruleMajorArity c)).map g1 = fArgs :=
+    Pattern.varN_matches_paths _ fArgs h1 hMlen
+  have hg2 : (Pattern.varNPaths (.const c.ctor.raw.name)
+      (gen.ruleArgArity c)).map g2 = aArgs :=
+    Pattern.varN_matches_paths _ aArgs h2 hNlen
+  have hcapsVals := gen.captureArgs_apply (m1 := m1) hg1 hg2
+  -- length bookkeeping
+  have hcommon_le : source.nparams + gen.familyCount + gen.minorCount ≤
+      gen.ruleMajorArity c := Nat.le_add_right _ _
+  have hnp_le : source.nparams ≤ gen.ruleArgArity c := Nat.le_add_right _ _
+  have htakelen : (fArgs.take (source.nparams + gen.familyCount +
+      gen.minorCount)).length =
+      source.nparams + gen.familyCount + gen.minorCount := by
+    rw [List.length_take, hMlen]; omega
+  have hdroplen : (aArgs.drop source.nparams).length =
+      gen.ruleFieldCount c := by
+    rw [List.length_drop, hNlen]
+    show gen.ruleArgArity c - source.nparams = _
+    simp only [ruleArgArity]; omega
+  have hcapslen : (fArgs.take (source.nparams + gen.familyCount +
+      gen.minorCount) ++ aArgs.drop source.nparams).length =
+      ((gen.ruleBinders c).map (VExpr.instL m1)).length := by
+    rw [List.length_append, htakelen, hdroplen, List.length_map,
+      gen.ruleBinders_length]
+  -- tower shapes
+  have htype' : (gen.rule i c).type.instL m1 =
+      VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1))
+        ((VExpr.appN
+          (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount +
+            gen.ruleFieldCount c))
+          (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) := by
+    rw [gen.rule_type, VExpr.instL_forallN]
+  have hlhs' : (gen.rule i c).lhs.instL m1 =
+      VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1))
+        ((gen.ruleLhsBody c).instL m1) := by
+    rw [gen.rule_lhs, VExpr.instL_lamN]
+  -- tower typing at the working context
+  have hlhsT : env.HasType univs Γ
+      (VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1))
+        ((gen.ruleLhsBody c).instL m1))
+      ((gen.rule i c).type.instL m1) := by
+    rw [← hlhs']
+    exact (hwf.1.instL hm1).weak0 henvo
+  obtain ⟨hTel, T₀, hbody⟩ := VEnv.HasType.lamN_wf henvo hΓ hlhsT
+  -- β-collapse of the applied left tower
+  have hcapsF : env.SpineWF univs Γ
+      (VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1))
+        ((VExpr.appN
+          (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount +
+            gen.ruleFieldCount c))
+          (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1))
+      (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        aArgs.drop source.nparams) B := htype' ▸ hcaps
+  have hretT0 := (VEnv.SpineWF.retarget hcapsF hcapslen) T₀
+  have hcollapseL := VEnv.IsDefEq.appN_lamN henvo hTel hbody hretT0 hcapslen
+  -- the registered defeq, applied
+  have hex : env.IsDefEq univs Γ ((gen.rule i c).lhs.instL m1)
+      ((gen.rule i c).rhs.instL m1) ((gen.rule i c).type.instL m1) :=
+    .extra hreg hm1 hlen1
+  rw [hlhs'] at hex
+  have happlied := VEnv.IsDefEq.appN_congr hex hcaps
+  -- conclusion-side template computation
+  have hRHS : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1
+      (Sum.elim g1 g2) (gen.ruleRHS hcl h) =
+      VExpr.appN ((gen.rule i c).rhs.instL m1)
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams) := by
+    rw [ruleRHS]
+    simp only [Pattern.RHS.appN_apply, hcapsVals]
+    rfl
+  -- typing of the rule type's index spine
+  obtain ⟨u₀, htypeT⟩ := hlhsT.isType henvo hΓ
+  rw [htype'] at htypeT
+  obtain ⟨-, V', htypeBody⟩ := VEnv.HasType.forallN_wf henvo htypeT
+  have hCtxTel : OnCtx (((gen.ruleBinders c).map (VExpr.instL m1)).reverse ++ Γ)
+      (env.IsType univs) := VEnv.OnTel.onCtx hΓ hTel
+  rw [show ((VExpr.appN
+      (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount +
+        gen.ruleFieldCount c))
+      (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) =
+    VExpr.appN (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount +
+        gen.ruleFieldCount c))
+      ((gen.ruleIdx c ++ [gen.ruleCtorApp c]).map (VExpr.instL m1)) from by
+      rw [VExpr.instL_appN]; rfl] at htypeBody
+  have hargsWF := VEnv.HasType.appN_args_wf henv hCtxTel _ _ rfl htypeBody
+  -- check extraction
+  unfold ruleCheck at hck
+  obtain ⟨hparams, hidxOK⟩ := Pattern.Check.OK.of_foldr _ _ hck
+  obtain ⟨hidxs, -⟩ := Pattern.Check.OK.of_foldr _ _ hidxOK
+  -- per-index tower collapse and check composition
+  have hidxLink : ∀ x ∈ (gen.ruleIdx c).attach.zip
+      ((Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)).drop
+        (source.nparams + gen.familyCount + gen.minorCount)),
+      env.IsDefEqU univs Γ (Sum.elim g1 g2 (Sum.inl x.2))
+        (VExpr.instRev (x.1.1.instL m1)
+          (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+            aArgs.drop source.nparams)) := by
+    intro x hx
+    have hfact := hidxs x hx
+    simp only [Pattern.RHS.appN_apply, hcapsVals] at hfact
+    have htower : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1
+        (Sum.elim g1 g2)
+        (.fixed (VExpr.lamN (gen.ruleBinders c) x.1.1)
+          (hcl.idxTower_closed hc x.1.1 x.1.2)) =
+        VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1))
+          (x.1.1.instL m1) := by
+      show (VExpr.lamN (gen.ruleBinders c) x.1.1).instL m1 = _
+      rw [VExpr.instL_lamN]
+    rw [htower] at hfact
+    obtain ⟨Tx, hTx⟩ := hargsWF (x.1.1.instL m1)
+      (by
+        rw [List.map_append]
+        exact List.mem_append.2 (.inl (List.mem_map_of_mem x.1.2)))
+    have hretTx := (VEnv.SpineWF.retarget hcapsF hcapslen) Tx
+    have hcollapseX := VEnv.IsDefEq.appN_lamN henvo hTel hTx hretTx hcapslen
+    exact VEnv.IsDefEqU.trans henv hΓ hfact ⟨_, hcollapseX⟩
+  -- major premise: constructor spine against its rebuilt form
+  have hparamsF₂ : List.Forall₂
+      (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a')
+      aArgs
+      (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by
+    have hb := forall₂_zip_map (α := Pattern.Path
+        (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c)))
+      (β := Pattern.Path
+        (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c)))
+      g2 g1 (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a')
+      ((Pattern.varNPaths (.const c.ctor.raw.name)
+        (gen.ruleArgArity c)).take source.nparams)
+      ((Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)).take source.nparams)
+      (by
+        rw [List.length_take, List.length_take,
+          Pattern.varNPaths_length, Pattern.varNPaths_length]
+        omega)
+      (fun p hp => Or.inr (hparams p hp))
+    rw [List.map_take, List.map_take, hg1, hg2] at hb
+    have hall := forall₂_append hb
+      (forall₂_refl_or (R := env.IsDefEqU univs Γ)
+        (aArgs.drop source.nparams))
+    rwa [List.take_append_drop] at hall
+  have hmajorLink : env.IsDefEqU univs Γ
+      (VExpr.appN (.const c.ctor.raw.name
+        (gen.sourceLevels.map (VLevel.inst m1))) aArgs)
+      (VExpr.appN (.const c.ctor.raw.name
+        (gen.sourceLevels.map (VLevel.inst m1)))
+        (fArgs.take source.nparams ++ aArgs.drop source.nparams)) :=
+    ⟨_, VEnv.IsDefEq.appN_defEq hctorhead
+      (VEnv.SpineWF.defEq_of_pointwise henv hΓ hctorspine hparamsF₂)⟩
+  -- the collapsed left spine, computed
+  have hL : (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+      aArgs.drop source.nparams).length =
+      gen.ruleFieldCount c +
+        (source.nparams + gen.familyCount + gen.minorCount) := by
+    rw [List.length_append, htakelen, hdroplen]; omega
+  have hcapsTake : (fArgs.take (source.nparams + gen.familyCount +
+      gen.minorCount) ++ aArgs.drop source.nparams).take
+      (source.nparams + gen.familyCount + gen.minorCount) =
+      fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by
+    rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take
+      (source.nparams + gen.familyCount + gen.minorCount)).length)]
+    exact List.take_of_length_le (Nat.le_of_eq htakelen)
+  have hcapsTakeNp : (fArgs.take (source.nparams + gen.familyCount +
+      gen.minorCount) ++ aArgs.drop source.nparams).take source.nparams =
+      fArgs.take source.nparams := by
+    rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take
+      (source.nparams + gen.familyCount + gen.minorCount)).length)]
+    rw [List.take_take]
+    congr 1
+    omega
+  have hcapsDrop : (fArgs.take (source.nparams + gen.familyCount +
+      gen.minorCount) ++ aArgs.drop source.nparams).drop
+      (source.nparams + gen.familyCount + gen.minorCount) =
+      aArgs.drop source.nparams := by
+    have hdl := List.drop_left (l₁ := fArgs.take (source.nparams + gen.familyCount + gen.minorCount)) (l₂ := aArgs.drop source.nparams)
+    rwa [htakelen] at hdl
+  have hsegNp : (VExpr.bvarRevRange
+      (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount))
+      source.nparams).map (VExpr.instRev ·
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams)) = fArgs.take source.nparams := by
+    rw [VExpr.map_instRev_bvarRevRange_seg _ source.nparams _ (by omega)]
+    rw [show (fArgs.take (source.nparams + gen.familyCount +
+        gen.minorCount) ++ aArgs.drop source.nparams).length -
+        (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) -
+        source.nparams = 0 from by omega, List.drop_zero]
+    exact hcapsTakeNp
+  have hsegFld : (VExpr.bvarRevRange 0 (gen.ruleFieldCount c)).map
+      (VExpr.instRev ·
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams)) = aArgs.drop source.nparams := by
+    rw [VExpr.map_instRev_bvarRevRange_seg _ (gen.ruleFieldCount c) 0
+      (by omega)]
+    rw [show (fArgs.take (source.nparams + gen.familyCount +
+        gen.minorCount) ++ aArgs.drop source.nparams).length - 0 -
+        gen.ruleFieldCount c =
+        source.nparams + gen.familyCount + gen.minorCount from by omega]
+    rw [hcapsDrop]
+    exact List.take_of_length_le (Nat.le_of_eq hdroplen)
+  have hsegCommon : (VExpr.bvarRevRange (gen.ruleFieldCount c)
+      (source.nparams + gen.familyCount + gen.minorCount)).map
+      (VExpr.instRev ·
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams)) =
+      fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by
+    rw [VExpr.map_instRev_bvarRevRange_seg _
+      (source.nparams + gen.familyCount + gen.minorCount)
+      (gen.ruleFieldCount c) (by omega)]
+    rw [show (fArgs.take (source.nparams + gen.familyCount +
+        gen.minorCount) ++ aArgs.drop source.nparams).length -
+        gen.ruleFieldCount c -
+        (source.nparams + gen.familyCount + gen.minorCount) = 0 from by
+        omega, List.drop_zero]
+    exact hcapsTake
+  have hctorImg : VExpr.instRev ((gen.ruleCtorApp c).instL m1)
+      (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        aArgs.drop source.nparams) =
+      VExpr.appN (.const c.ctor.raw.name
+          (gen.sourceLevels.map (VLevel.inst m1)))
+        (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by
+    rw [gen.ruleCtorApp_instL, VExpr.instRev_appN,
+      VExpr.instRev_closedN (C := .const c.ctor.raw.name
+        (gen.sourceLevels.map (VLevel.inst m1))) _ trivial, List.map_append,
+      hsegNp, hsegFld]
+  have hcollapsedEq : VExpr.instRev ((gen.ruleLhsBody c).instL m1)
+      (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        aArgs.drop source.nparams) =
+      VExpr.appN (.const (gen.ruleRecName c) m1)
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1)
+            (fArgs.take (source.nparams + gen.familyCount +
+              gen.minorCount) ++ aArgs.drop source.nparams)) ++
+          [VExpr.appN (.const c.ctor.raw.name
+              (gen.sourceLevels.map (VLevel.inst m1)))
+            (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by
+    rw [gen.ruleLhsBody_instL c hlen1, VExpr.instRev_appN,
+      VExpr.instRev_closedN (C := .const (gen.ruleRecName c) m1) _ trivial,
+      List.map_append, List.map_append, hsegCommon, List.map_map]
+    rw [show ((gen.ruleCtorApp c).instL m1 ::
+        ([] : List VExpr)).map (VExpr.instRev ·
+          (fArgs.take (source.nparams + gen.familyCount +
+            gen.minorCount) ++ aArgs.drop source.nparams)) =
+        [VExpr.instRev ((gen.ruleCtorApp c).instL m1)
+          (fArgs.take (source.nparams + gen.familyCount +
+            gen.minorCount) ++ aArgs.drop source.nparams)] from rfl]
+    rw [hctorImg]
+    simp only [Function.comp_def]
+    rw [List.append_assoc]
+  -- pointwise defeq between the redex spine and the collapsed spine
+  have hidxF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a')
+      (fArgs.drop (source.nparams + gen.familyCount + gen.minorCount))
+      ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1)
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams))) := by
+    have hb := forall₂_zip_map
+      (α := {x // x ∈ gen.ruleIdx c})
+      (β := Pattern.Path (Pattern.varN (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)))
+      (fun s => VExpr.instRev (s.1.instL m1)
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+          aArgs.drop source.nparams))
+      (fun p => Sum.elim g1 g2 (Sum.inl p))
+      (fun t v => v = t ∨ env.IsDefEqU univs Γ v t)
+      (gen.ruleIdx c).attach
+      ((Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)).drop
+        (source.nparams + gen.familyCount + gen.minorCount))
+      (by
+        rw [List.length_attach, List.length_drop, Pattern.varNPaths_length]
+        show (gen.ruleIdx c).length = gen.ruleMajorArity c - _
+        simp only [ruleIdx, ruleMajorArity, List.length_map]
+        omega)
+      (fun p hp => Or.inr (hidxLink p hp))
+    have hflip := List.Forall₂.flip hb
+    have hmapG : ((Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)).drop
+        (source.nparams + gen.familyCount + gen.minorCount)).map
+        (fun p => Sum.elim g1 g2 (Sum.inl p)) =
+        fArgs.drop (source.nparams + gen.familyCount + gen.minorCount) := by
+      show ((Pattern.varNPaths (.const (gen.ruleRecName c))
+        (gen.ruleMajorArity c)).drop
+        (source.nparams + gen.familyCount + gen.minorCount)).map g1 = _
+      rw [List.map_drop, hg1]
+    have hmapF : ((gen.ruleIdx c).attach).map
+        (fun s => VExpr.instRev (s.1.instL m1)
+          (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+            aArgs.drop source.nparams)) =
+        (gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1)
+          (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+            aArgs.drop source.nparams)) := by
+      exact List.attach_map_val
+        (f := fun x : VExpr => VExpr.instRev (x.instL m1)
+          (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+            aArgs.drop source.nparams)) ..
+    rw [hmapG, hmapF] at hflip
+    exact hflip
+  have hbigF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a')
+      (fArgs ++ [VExpr.appN (.const c.ctor.raw.name
+        (gen.sourceLevels.map (VLevel.inst m1))) aArgs])
+      (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+        ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1)
+          (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++
+            aArgs.drop source.nparams)) ++
+        [VExpr.appN (.const c.ctor.raw.name
+            (gen.sourceLevels.map (VLevel.inst m1)))
+          (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by
+    have hres := forall₂_append
+      (forall₂_refl_or (R := env.IsDefEqU univs Γ)
+        (fArgs.take (source.nparams + gen.familyCount + gen.minorCount)))
+      (forall₂_append hidxF₂ (.cons (Or.inr hmajorLink) .nil))
+    rwa [← List.append_assoc, List.take_append_drop] at hres
+  -- the redex is defeq to the collapsed left spine
+  have hE := VEnv.IsDefEq.appN_defEq hehead
+    (VEnv.SpineWF.defEq_of_pointwise henv hΓ hespine hbigF₂)
+  rw [← hcollapsedEq, VExpr.appN_append] at hE
+  -- assemble
+  rw [hRHS]
+  exact VEnv.IsDefEqU.trans henv hΓ ⟨_, hE⟩
+    (VEnv.IsDefEqU.trans henv hΓ ⟨_, hcollapseL.symm⟩ ⟨_, happlied⟩)
+
+end BlockGenerationChecked
+
+end VInductDecl
+
+end Lean4Lean
+
+/-! ## Axiom closures
+
+The typed β-collapse layer is sorry-free. `pat_wf` composes typed defeqs
+through `IsDefEqU.of_l`/`IsDefEqU.trans` and therefore carries exactly the
+transitional unique-typing closure the Church–Rosser development itself
+carries; it sheds `sorryAx` automatically when the L4L-16/17 inversion
+milestones land, with no restatement. -/
+
+/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_lamN' depends on axioms: [propext, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.VEnv.IsDefEq.appN_lamN
+
+/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_defEq' depends on axioms: [propext] -/
+#guard_msgs in
+#print axioms Lean4Lean.VEnv.IsDefEq.appN_defEq
+
+/-- info: 'Lean4Lean.VEnv.LE.extra' depends on axioms: [propext] -/
+#guard_msgs in
+#print axioms Lean4Lean.VEnv.LE.extra
+
+/-- info: 'Lean4Lean.VEnv.LE.extra_appN' depends on axioms: [propext] -/
+#guard_msgs in
+#print axioms Lean4Lean.VEnv.LE.extra_appN
+
+/-- info: 'Lean4Lean.VEnv.LE.extra_appN_symm' depends on axioms: [propext] -/
+#guard_msgs in
+#print axioms Lean4Lean.VEnv.LE.extra_appN_symm
+
+/-- info: 'Lean4Lean.Pattern.varN_matches_paths' depends on axioms: [propext, Classical.choice, Quot.sound] -/
+#guard_msgs in
+#print axioms Lean4Lean.Pattern.varN_matches_paths
+
+/--
+info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf
diff --git a/Lean4Lean/Theory/Typing/Lemmas.lean b/Lean4Lean/Theory/Typing/Lemmas.lean
index f7691e6d..0af006d1 100644
--- a/Lean4Lean/Theory/Typing/Lemmas.lean
+++ b/Lean4Lean/Theory/Typing/Lemmas.lean
@@ -9,7 +9,7 @@ inductive Ctx.LiftN (n : Nat) : Nat → List VExpr → List VExpr → Prop where
   | zero (As) (h : As.length = n := by rfl) : Ctx.LiftN n 0 Γ (As ++ Γ)
   | succ : Ctx.LiftN n k Γ Γ' → Ctx.LiftN n (k+1) (A::Γ) (A.liftN n k :: Γ')
 
-def Ctx.LiftN.one : Ctx.LiftN 1 0 Γ (A::Γ) := .zero [_]
+theorem Ctx.LiftN.one : Ctx.LiftN 1 0 Γ (A::Γ) := .zero [_]
 
 theorem Ctx.LiftN.isSuffix (H : Ctx.LiftN n k Γ Γ') :
     ∃ Γ₀ As Δ Δ',
@@ -149,11 +149,6 @@ theorem Lookup.instL : Lookup Γ i A → Lookup (Γ.map (VExpr.instL ls)) i (A.i
   | .zero => instL_liftN ▸ .zero
   | .succ h => instL_liftN ▸ .succ h.instL
 
-def OnCtx (Γ : List VExpr) (P : List VExpr → VExpr → Prop) : Prop :=
-  match Γ with
-  | [] => True
-  | A::Γ => OnCtx Γ P ∧ P Γ A
-
 theorem OnCtx.lookup (h : OnCtx Γ P) (hL : Lookup Γ n A)
     (hP : ∀ {Γ A B}, P Γ A → P (B::Γ) A.lift) : P Γ A :=
   match hL, h with
@@ -177,6 +172,12 @@ theorem Ctx.LiftN.right (h : CtxClosed Γ) (Γ') : Ctx.LiftN Γ'.length Γ.lengt
   | A :: Γ, ⟨h1, h2⟩ => by
     simpa [h2.liftN_eq (Nat.le_refl _)] using LiftN.succ (LiftN.right h1 Γ') (A := A)
 
+theorem VStructEta.WF.mono {rule : VStructEta} {env env' : VEnv}
+    (henv : env ≤ env') (self : VStructEta.WF rule env) :
+    VStructEta.WF rule env' where
+  familyType_closed := self.familyType_closed
+  rebuild_hasType hle := self.rebuild_hasType (henv.trans hle)
+
 inductive VObject where
   | const (n : Name) (ci : VConstant)
   | defeq (df : VDefEq)
@@ -185,7 +186,7 @@ namespace VEnv
 
 theorem addConst_le {env env' : VEnv} (h : env.addConst n ci = some env') : env ≤ env' := by
   unfold addConst at h; split at h <;> cases h
-  exact ⟨fun _ => by simp; split <;> simp_all, by simp [*]⟩
+  exact ⟨fun _ => by simp; split <;> simp_all, by simp [*], by simp [*]⟩
 
 theorem addConst_self {env env' : VEnv} (h : env.addConst n ci = some env') :
     env'.constants n = some ci := by
@@ -212,7 +213,8 @@ theorem LE.addConst {env₁ env₂ env₁' env₂' : VEnv} (henv : env₁ ≤ en
       simp at h ⊢
       split at h <;> split <;> simp_all
       exact henv.constants h
-    defeqs := henv.defeqs }
+    defeqs := henv.defeqs
+    structEtas := henv.structEtas }
 
 /-- Absence of a constant pulls back along environment growth. -/
 theorem LE.constants_none {env env' : VEnv} (henv : env ≤ env')
@@ -224,10 +226,16 @@ theorem LE.constants_none {env env' : VEnv} (henv : env ≤ env')
     rw [h] at this
     contradiction
 
-theorem addDefEq_le {env : VEnv} : env ≤ env.addDefEq df := ⟨id, .inr⟩
+theorem addDefEq_le {env : VEnv} : env ≤ env.addDefEq df := ⟨id, .inr, id⟩
 
 theorem addDefEq_self {env : VEnv} : (env.addDefEq df).defeqs df := .inl rfl
 
+theorem addStructEta_le {env : VEnv} : env ≤ env.addStructEta rule :=
+  ⟨id, id, .inr⟩
+
+theorem addStructEta_self {env : VEnv} :
+    (env.addStructEta rule).structEtas rule := .inl rfl
+
 def HasObjects (env : VEnv) : List VObject → Prop
   | [] => True
   | .const n ci :: ls => env.constants n = some ci ∧ env.HasObjects ls
@@ -289,6 +297,7 @@ inductive Ordered : VEnv → Prop where
     Ordered env → ci.WF env →
     env.addConst n ci = some env' → Ordered env'
   | defeq : Ordered env → df.WF env → Ordered (env.addDefEq df)
+  | structEta : Ordered env → rule.WF env → Ordered (env.addStructEta rule)
 
 def OnTypes (env : VEnv) (P : Nat → VExpr → VExpr → Prop) : Prop :=
   (∀ {n ci}, env.constants n = some ci → ∃ u, P ci.uvars ci.type (.sort u)) ∧
@@ -322,6 +331,8 @@ theorem Ordered.induction (motive : VEnv → Nat → VExpr → VExpr → Prop)
     · let ⟨hl, hr⟩ := h2
       exact ⟨type h1 ih hl, type h1 ih hr⟩
     · exact ih.2 hdf
+  | structEta _ _ ih =>
+    exact OnTypes.mono .rfl (mono addStructEta_le) ih
 
 variable (env : VEnv) (U : Nat) (Γ₀ : List VExpr) in
 inductive IsDefEqCtx : List VExpr → List VExpr → Prop
@@ -353,7 +364,8 @@ theorem IsDefEqCtx.refl : ∀ {Γ}, OnCtx Γ (env.IsType U) → IsDefEqCtx env U
 variable! (henv : OnTypes env fun _ e A => e.ClosedN ∧ A.ClosedN) in
 theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) :
     e1.ClosedN Γ.length ∧ e2.ClosedN Γ.length ∧ A.ClosedN Γ.length := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | bvar h => exact ⟨h.lt, h.lt, hΓ.lookup h⟩
   | constDF h1 =>
     let ⟨_, h, _⟩ := henv.1 h1
@@ -381,6 +393,10 @@ theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) :
   | eta _ ih =>
     let ⟨he, _, hA, hB⟩ := ih hΓ
     exact ⟨⟨hA, he.liftN, Nat.succ_pos _⟩, he, hA, hB⟩
+  | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    let ⟨hmajor, _, htype⟩ := ihMajor hΓ
+    let ⟨hrebuild, _, _⟩ := ihRebuild hΓ
+    exact ⟨hrebuild, hmajor, htype⟩
   | proofIrrel _ _ _ _ ih2 ih3 =>
     let ⟨hh, _, _⟩ := ih2 hΓ
     let ⟨hh', _, hp⟩ := ih3 hΓ
@@ -391,6 +407,7 @@ theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) :
       hl.instL.mono (Nat.zero_le _),
       hr.instL.mono (Nat.zero_le _),
       hA.instL.mono (Nat.zero_le _)⟩
+  | nil | cons => trivial
 
 theorem Ordered.closed (H : Ordered env) : env.OnTypes fun _ e A => e.ClosedN ∧ A.ClosedN :=
   H.induction _ (fun _ => id) fun _ ih h => (IsDefEq.closedN' ih h trivial).2
@@ -417,7 +434,8 @@ theorem IsDefEqCtx.closed (H : CtxClosed Γ₀) :
 
 variable! {env env' : VEnv} (henv : env ≤ env') in
 theorem IsDefEq.mono (H : env.IsDefEq U Γ e1 e2 A) : env'.IsDefEq U Γ e1 e2 A := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun Γ A es B _ => env'.SpineWF U Γ A es B) with
   | bvar h => exact .bvar h
   | constDF h1 h2 h3 h4 h5 => exact .constDF (henv.1 h1) h2 h3 h4 h5
   | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
@@ -429,12 +447,36 @@ theorem IsDefEq.mono (H : env.IsDefEq U Γ e1 e2 A) : env'.IsDefEq U Γ e1 e2 A
   | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
   | beta _ _ ih1 ih2 => exact .beta ih1 ih2
   | eta _ ih => exact .eta ih
+  | structEta hreg hlevels hlevelsLength hparamsLength _ _ _
+      ihSpine ihMajor ihRebuild =>
+    exact .structEta (henv.structEtas hreg) hlevels hlevelsLength
+      hparamsLength ihSpine ihMajor ihRebuild
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
   | extra h1 h2 h3 => exact .extra (henv.2 h1) h2 h3
+  | nil => exact .nil
+  | cons _ _ ihType ihRest => exact .cons ihType ihRest
 
 theorem HasType.mono {env env' : VEnv} (henv : env ≤ env') :
     env.HasType U Γ e A → env'.HasType U Γ e A := IsDefEq.mono henv
 
+theorem SpineWF.mono {env env' : VEnv} (henv : env ≤ env') {U : Nat}
+    {Γ : List VExpr} : ∀ {es A B}, env.SpineWF U Γ A es B →
+      env'.SpineWF U Γ A es B
+  | [], _, _, .nil => .nil
+  | _ :: _, _, _, .cons he hrest =>
+    .cons (he.mono henv) (SpineWF.mono henv hrest)
+
+theorem SpineWF.nil_inv {env : VEnv} (h : env.SpineWF U Γ A [] B) : A = B := by
+  cases h
+  rfl
+
+theorem SpineWF.cons_inv {env : VEnv}
+    (h : env.SpineWF U Γ A (e :: es) B) :
+    ∃ A₁ A₂, A = .forallE A₁ A₂ ∧
+      env.HasType U Γ e A₁ ∧ env.SpineWF U Γ (A₂.inst e) es B := by
+  cases h with
+  | cons he hrest => exact ⟨_, _, rfl, he, hrest⟩
+
 theorem IsType.mono {env env' : VEnv} (henv : env ≤ env') : env.IsType U Γ A → env'.IsType U Γ A
   | ⟨u, h⟩ => ⟨u, h.mono henv⟩
 
@@ -467,6 +509,7 @@ theorem Ordered.constWF (H : Ordered env) (h : env.constants n = some ci) : ci.W
     · cases h; exact h2
     · exact ih h
   | defeq _ _ ih => exact .mono addDefEq_le (ih h)
+  | structEta _ _ ih => exact .mono addStructEta_le (ih h)
 
 theorem Ordered.defEqWF (H : Ordered env) (h : env.defeqs df) : df.WF env := by
   induction H with
@@ -479,6 +522,22 @@ theorem Ordered.defEqWF (H : Ordered env) (h : env.defeqs df) : df.WF env := by
     obtain rfl | h := h
     · assumption
     · exact ih h
+  | structEta _ _ ih => exact .mono addStructEta_le (ih h)
+
+theorem Ordered.structEtaWF (H : Ordered env) (h : env.structEtas rule) :
+    VStructEta.WF rule env := by
+  induction H with
+  | empty => cases h
+  | const _ _ hadd ih =>
+    refine VStructEta.WF.mono (addConst_le hadd) (ih ?_)
+    unfold VEnv.addConst at hadd
+    split at hadd <;> cases hadd
+    exact h
+  | defeq _ _ ih => exact VStructEta.WF.mono addDefEq_le (ih h)
+  | structEta _ hwf ih =>
+    obtain rfl | h := h
+    · exact VStructEta.WF.mono addStructEta_le hwf
+    · exact VStructEta.WF.mono addStructEta_le (ih h)
 
 variable! (henv : Ordered env) in
 theorem CtxWF.closed (h : OnCtx Γ (IsType env U)) : CtxClosed Γ :=
@@ -489,7 +548,8 @@ theorem CtxWF.closed (h : OnCtx Γ (IsType env U)) : CtxClosed Γ :=
 variable {env : VEnv} in
 theorem IsDefEq.levelWF (H : env.IsDefEq U Γ e1 e2 A) (W : OnCtx Γ fun _ A => A.LevelWF U) :
     e1.LevelWF U ∧ e2.LevelWF U ∧ A.LevelWF U := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | bvar h =>
     refine ⟨⟨⟩, ⟨⟩, ?_⟩
     induction h with
@@ -513,10 +573,15 @@ theorem IsDefEq.levelWF (H : env.IsDefEq U Γ e1 e2 A) (W : OnCtx Γ fun _ A =>
     let ⟨he', _, hA⟩ := ih2 W; let ⟨he, _, hB⟩ := ih1 ⟨W, hA⟩
     exact ⟨⟨⟨hA, he⟩, he'⟩, he.inst he', hB.inst he'⟩
   | eta _ ih => let ⟨he, _, hA, hB⟩ := ih W; exact ⟨⟨hA, he.liftN, ⟨⟩⟩, he, hA, hB⟩
+  | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    let ⟨hmajor, _, htype⟩ := ihMajor W
+    let ⟨hrebuild, _, _⟩ := ihRebuild W
+    exact ⟨hrebuild, hmajor, htype⟩
   | proofIrrel _ _ _ _ ih2 ih3 =>
     let ⟨hh, _, hp⟩ := ih2 W; let ⟨hh', _, _⟩ := ih3 W
     exact ⟨hh, hh', hp⟩
   | extra _ h2 => exact ⟨.instL h2, .instL h2, .instL h2⟩
+  | nil | cons => trivial
 
 theorem HasType.const0 (H : env.constants c = some ci) (wf : ci.WF env) :
     HasType env ci.uvars [] (.const c (VLevel.params ci.uvars)) ci.type := by
@@ -533,7 +598,11 @@ theorem IsDefEq.extra0 (H : env.defeqs df) (wf : df.WF env) :
 variable! (henv : Ordered env) in
 theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A) :
     env.IsDefEq U Γ' (e1.liftN n k) (e2.liftN n k) (A.liftN n k) := by
-  induction H generalizing k Γ' with
+  induction H using IsDefEq.rec
+      (motive_2 := fun Γ A es B _ => ∀ {k Γ'}, Ctx.LiftN n k Γ Γ' →
+        env.SpineWF U Γ' (A.liftN n k)
+          (es.map fun e => e.liftN n k) (B.liftN n k))
+      generalizing k Γ' with
   | bvar h => refine .bvar (h.weakN W)
   | symm _ ih => exact .symm (ih W)
   | trans _ _ ih1 ih2 => exact .trans (ih1 W) (ih2 W)
@@ -550,6 +619,21 @@ theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A)
   | eta _ ih =>
     have := IsDefEq.eta (ih W)
     simp [liftN]; rwa [← lift_liftN']
+  | @structEta rule levels _ params _ major hreg hlevels
+      hlevelsLength hparamsLength _ _ _
+      ihSpine ihMajor ihRebuild =>
+    have hparamsSpine := ihSpine W
+    rw [(henv.structEtaWF hreg).familyType_closed.instL.liftN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor := ihMajor W
+    rw [VStructEta.structureType_liftN] at hmajor
+    have hrebuild := ihRebuild W
+    rw [VStructEta.rebuild_liftN rule levels params major
+      hparamsLength n k, VStructEta.structureType_liftN] at hrebuild
+    have hout := IsDefEq.structEta hreg hlevels hlevelsLength
+      (by simpa using hparamsLength) hparamsSpine hmajor hrebuild
+    simpa only [VStructEta.rebuild_liftN rule levels params major
+      hparamsLength n k, VStructEta.structureType_liftN] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
   | extra h1 h2 h3 =>
     have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
@@ -558,11 +642,25 @@ theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A)
       hA2.instL.liftN_eq (Nat.zero_le _),
       hA3.instL.liftN_eq (Nat.zero_le _)]
     exact .extra h1 h2 h3
+  | nil => exact .nil
+  | cons _ _ ihType ihRest =>
+    exact .cons (ihType (by assumption)) (by
+      simpa only [VExpr.liftN_inst_hi] using ihRest (by assumption))
 
 variable! (henv : Ordered env) in
 theorem HasType.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.HasType U Γ e A) :
     env.HasType U Γ' (e.liftN n k) (A.liftN n k) := IsDefEq.weakN henv W H
 
+theorem SpineWF.weakN {env : VEnv} (henv : env.Ordered)
+    (W : Ctx.LiftN n k Γ Γ') :
+    ∀ {es A B}, env.SpineWF U Γ A es B →
+      env.SpineWF U Γ' (A.liftN n k)
+        (es.map fun e => e.liftN n k) (B.liftN n k)
+  | [], _, _, .nil => .nil
+  | _ :: _, _, _, .cons he hrest =>
+    .cons (he.weakN henv W) (by
+      simpa only [VExpr.liftN_inst_hi] using SpineWF.weakN henv W hrest)
+
 variable! (henv : Ordered env) in
 theorem IsType.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsType U Γ A) :
     env.IsType U Γ' (A.liftN n k) := let ⟨_, h⟩ := H; ⟨_, h.weakN henv W⟩
@@ -627,7 +725,10 @@ theorem IsType.lookup (henv : Ordered env) (h : OnCtx Γ (IsType env U)) (hL : L
 variable! {env : VEnv} {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') in
 theorem IsDefEq.instL (H : env.IsDefEq U Γ e1 e2 A) :
     env.IsDefEq U' (Γ.map (VExpr.instL ls)) (e1.instL ls) (e2.instL ls) (A.instL ls) := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun Γ A es B _ =>
+        env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls)
+          (es.map (VExpr.instL ls)) (B.instL ls)) with
   | bvar h => refine .bvar h.instL
   | symm _ ih => exact .symm ih
   | trans _ _ ih1 ih2 => exact .trans ih1 ih2
@@ -643,14 +744,44 @@ theorem IsDefEq.instL (H : env.IsDefEq U Γ e1 e2 A) :
   | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
   | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2
   | eta _ ih => simpa [VExpr.instL] using .eta ih
+  | @structEta rule levels _ params _ major hreg hlevels
+      hlevelsLength hparamsLength _ _ _
+      ihSpine ihMajor ihRebuild =>
+    have hlevels' : ∀ level ∈ levels.map (VLevel.inst ls),
+        level.WF U' := by
+      intro level hlevel
+      obtain ⟨source, hsource, heq⟩ := List.mem_map.1 hlevel
+      rw [← heq]
+      exact VLevel.WF.inst hls
+    rw [VStructEta.structureType_instL] at ihMajor
+    rw [VStructEta.rebuild_instL,
+      VStructEta.structureType_instL] at ihRebuild
+    rw [VExpr.instL_instL] at ihSpine
+    have hout := IsDefEq.structEta hreg hlevels'
+      (by simpa using hlevelsLength)
+      (by simpa using hparamsLength) ihSpine ihMajor ihRebuild
+    simpa only [VStructEta.rebuild_instL,
+      VStructEta.structureType_instL] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
   | extra h1 h2 h3 =>
     simp [VExpr.instL_instL]
     exact .extra h1 (by simp [VLevel.WF.inst hls]) (by simp [h3])
+  | nil => exact .nil
+  | cons _ _ ihType ihRest =>
+    exact .cons ihType (by simpa using ihRest)
 
 theorem HasType.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') (H : env.HasType U Γ e A) :
     env.HasType U' (Γ.map (VExpr.instL ls)) (e.instL ls) (A.instL ls) := IsDefEq.instL hls H
 
+theorem SpineWF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') :
+    ∀ {es A B}, env.SpineWF U Γ A es B →
+      env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls)
+        (es.map (VExpr.instL ls)) (B.instL ls)
+  | [], _, _, .nil => .nil
+  | _ :: _, _, _, .cons he hrest =>
+    .cons (he.instL hls) (by
+      simpa using SpineWF.instL hls hrest)
+
 theorem IsType.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') (H : env.IsType U Γ A) :
     env.IsType U' (Γ.map (VExpr.instL ls)) (A.instL ls) := let ⟨_, h⟩ := H; ⟨_, h.instL hls⟩
 
@@ -666,7 +797,11 @@ theorem _root_.Lean4Lean.OnCtx.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U')
 variable! (henv : Ordered env) (h₀ : env.HasType U Γ₀ e₀ A₀) in
 theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefEq U Γ₁ e1 e2 A) :
     env.IsDefEq U Γ (e1.inst e₀ k) (e2.inst e₀ k) (A.inst e₀ k) := by
-  induction H generalizing Γ k with
+  induction H using IsDefEq.rec
+      (motive_2 := fun Γ₁ A es B _ => ∀ {Γ k}, Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ →
+        env.SpineWF U Γ (A.inst e₀ k)
+          (es.map fun e => e.inst e₀ k) (B.inst e₀ k))
+      generalizing Γ k with
   | @bvar _ i ty h =>
     dsimp [inst]
     induction W generalizing i ty with
@@ -694,6 +829,21 @@ theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefE
     have := IsDefEq.eta (ih W)
     rw [lift, VExpr.liftN_instN_lo (hj := Nat.zero_le _), Nat.add_comm] at this
     simpa [inst]
+  | @structEta rule levels _ params _ major hreg hlevels
+      hlevelsLength hparamsLength _ _ _
+      ihSpine ihMajor ihRebuild =>
+    have hparamsSpine := ihSpine W
+    rw [(henv.structEtaWF hreg).familyType_closed.instL.instN_eq
+      (Nat.zero_le _)] at hparamsSpine
+    have hmajor := ihMajor W
+    rw [VStructEta.structureType_instN] at hmajor
+    have hrebuild := ihRebuild W
+    rw [VStructEta.rebuild_instN rule levels params major e₀
+      hparamsLength k, VStructEta.structureType_instN] at hrebuild
+    have hout := IsDefEq.structEta hreg hlevels hlevelsLength
+      (by simpa using hparamsLength) hparamsSpine hmajor hrebuild
+    simpa only [VStructEta.rebuild_instN rule levels params major e₀
+      hparamsLength k, VStructEta.structureType_instN] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
   | extra h1 h2 h3 =>
     have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
@@ -702,6 +852,22 @@ theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefE
       hA2.instL.instN_eq (Nat.zero_le _),
       hA3.instL.instN_eq (Nat.zero_le _)]
     exact .extra h1 h2 h3
+  | nil => exact .nil
+  | cons _ _ ihType ihRest =>
+    exact .cons (ihType (by assumption)) (by
+      simpa only [VExpr.inst0_inst_hi] using ihRest (by assumption))
+
+theorem SpineWF.instN {env : VEnv} (henv : env.Ordered)
+    (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (h₀ : env.HasType U Γ₀ e₀ A₀) :
+    ∀ {es A B}, env.SpineWF U Γ₁ A es B →
+      env.SpineWF U Γ (A.inst e₀ k)
+        (es.map fun e => e.inst e₀ k) (B.inst e₀ k)
+  | [], _, _, .nil => .nil
+  | _ :: _, _, _, .cons he hrest =>
+    .cons (IsDefEq.instN henv h₀ W he) (by
+      simpa only [VExpr.inst0_inst_hi] using
+        SpineWF.instN henv W h₀ hrest)
 
 theorem HasType.instN {env : VEnv} (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
     (H : env.HasType U Γ₁ e A) (h₀ : env.HasType U Γ₀ e₀ A₀) :
@@ -773,7 +939,9 @@ variable! (henv : Ordered env)
 theorem IsDefEq.forallE_inv'
     (H : env.IsDefEq U Γ e1 e2 V) (eq : e1 = A.forallE B ∨ e2 = A.forallE B) :
     env.IsType U Γ A ∧ env.IsType U (A::Γ) B := by
-  induction H generalizing A B with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True)
+      generalizing A B with
   | symm _ ih => exact ih eq.symm
   | trans _ _ ih1 ih2
   | proofIrrel _ _ _ _ ih1 ih2 =>
@@ -799,6 +967,10 @@ theorem IsDefEq.forallE_inv'
   | eta _ ih =>
     obtain ⟨⟨⟩⟩ | eq := eq
     exact ih (.inl eq)
+  | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    obtain eq | eq := eq
+    · exact ihRebuild (.inl eq)
+    · exact ihMajor (.inl eq)
   | @extra df ls Γ h1 h2 =>
     suffices ∀ e, VExpr.instL ls e = VExpr.forallE A B →
         (∀ A B, e = VExpr.forallE A B → IsType env df.uvars [] A ∧ IsType env df.uvars [A] B) →
@@ -814,6 +986,7 @@ theorem IsDefEq.forallE_inv'
     have C2 := (A2.instL h2).closedN henv ⟨⟨⟩, C1⟩
     rw [C1.liftN_eq (Nat.zero_le _), C2.liftN_eq (by exact Nat.le_refl _)] at this
     simpa [liftN]
+  | nil | cons => trivial
   | _ => nomatch eq
 
 theorem HasType.forallE_inv (henv : Ordered env) (H : env.HasType U Γ (A.forallE B) V) :
@@ -830,7 +1003,8 @@ theorem IsType.forallE_inv (henv : Ordered env) (H : env.IsType U Γ (A.forallE
 variable! (henv : Ordered env) in
 theorem IsDefEq.sort_inv'
     (H : env.IsDefEq U Γ e1 e2 V) (eq : e1 = .sort u ∨ e2 = .sort u) : u.WF U := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | symm _ ih => exact ih eq.symm
   | trans _ _ ih1 ih2
   | proofIrrel _ _ _ _ ih1 ih2 =>
@@ -847,6 +1021,10 @@ theorem IsDefEq.sort_inv'
   | eta _ ih =>
     obtain ⟨⟨⟩⟩ | eq := eq
     exact ih (.inl eq)
+  | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    obtain eq | eq := eq
+    · exact ihRebuild (.inl eq)
+    · exact ihMajor (.inl eq)
   | @extra df ls _ h1 h2 =>
     suffices ∀ e, VExpr.instL ls e = .sort u → HasType env df.uvars [] e df.type → u.WF U by
       have ⟨A1, A2⟩ := henv.defEqWF h1
@@ -854,6 +1032,7 @@ theorem IsDefEq.sort_inv'
     intro e eq IH
     cases e <;> cases eq; rename_i u
     exact VLevel.WF.inst h2
+  | nil | cons => trivial
   | _ => nomatch eq
 
 theorem IsDefEq.sort_inv_l (henv : Ordered env) (H : env.IsDefEq U Γ (.sort u) e2 V) : u.WF U :=
@@ -872,7 +1051,8 @@ variable! (henv : Ordered env)
   (envIH : env.OnTypes fun U e A => env.HasType U [] e A ∧ env.IsType U [] A) in
 theorem IsDefEq.isType' (hΓ : OnCtx Γ (env.IsType U)) (H : env.IsDefEq U Γ e1 e2 A) :
     env.IsType U Γ A := by
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | bvar h => exact .lookup henv hΓ h
   | proofIrrel h1 => exact ⟨_, h1⟩
   | extra h1 h2 =>
@@ -895,6 +1075,8 @@ theorem IsDefEq.isType' (hΓ : OnCtx Γ (env.IsType U)) (H : env.IsDefEq U Γ e1
     have ⟨_, h⟩ := ih2 hΓ
     exact (ih1 ⟨hΓ, _, h.hasType.2⟩).instN henv .zero h2
   | eta _ ih => exact ih hΓ
+  | structEta _ _ _ _ _ _ _ _ ihMajor _ => exact ihMajor hΓ
+  | nil | cons => trivial
 
 theorem Ordered.isType (H : Ordered env) :
     env.OnTypes fun U e A => env.HasType U [] e A ∧ env.IsType U [] A :=
diff --git a/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean
new file mode 100644
index 00000000..095bc531
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean
@@ -0,0 +1,184 @@
+import Lean4Lean.Theory.NestedInductive
+import Lean4Lean.Theory.Typing.InductiveLemmas
+
+/-!
+# Nested transaction facts and preservation (L4L-09C)
+
+The `addInductNested` analog of the block-wide transaction lemma suite:
+exact phase recovery, atomicity, monotonicity, freshness, lookup and rule
+membership through `ctorFold_spec`/`rulesFold_spec`, and `Ordered`
+preservation from the `NestedBlockChecked.WF` package.
+-/
+
+namespace Lean4Lean
+
+open VInductDecl
+
+namespace VEnv
+
+/-- Recover every phase boundary from a successful nested transaction. -/
+theorem addInductNested_trace {source : VInductDecl}
+    {nested : source.NestedBlockChecked}
+    (hadd : addInductNested env nested = some env') :
+    Nonempty (AddInductNestedTrace env env' nested) := by
+  unfold addInductNested at hadd
+  obtain ⟨typeEnv, addTypes, hadd⟩ := Option.bind_eq_some_iff.1 hadd
+  obtain ⟨ctorEnv, addCtors, hadd⟩ := Option.bind_eq_some_iff.1 hadd
+  obtain ⟨recEnv, addRecs, hadd⟩ := Option.bind_eq_some_iff.1 hadd
+  cases hadd
+  exact ⟨⟨typeEnv, ctorEnv, recEnv, addTypes, addCtors, addRecs, rfl⟩⟩
+
+/-- The nested transaction is atomic at its public `Option` boundary. -/
+theorem addInductNested_atomic {source : VInductDecl}
+    (env : VEnv) (nested : source.NestedBlockChecked) :
+    addInductNested env nested = none ∨
+      ∃ env', addInductNested env nested = some env' ∧
+        Nonempty (AddInductNestedTrace env env' nested) := by
+  cases hadd : addInductNested env nested with
+  | none => exact .inl rfl
+  | some env' => exact .inr ⟨env', rfl, addInductNested_trace hadd⟩
+
+namespace AddInductNestedTrace
+
+variable {source : VInductDecl} {nested : source.NestedBlockChecked}
+
+/-- Every phase of a successful nested transaction only grows the Theory
+environment. -/
+theorem le (H : AddInductNestedTrace env env' nested) : env ≤ env' := by
+  have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1
+  have hctors := (ctorFold_spec source.blockConstructorConstants H.addCtors).1
+  have hrecs := (ctorFold_spec nested.recursors H.addRecs).1
+  have hrules : H.recEnv ≤ env' := by
+    simpa only [H.addRules] using
+      (rulesFold_spec nested.generatedRules H.recEnv).1
+  exact htypes.trans (hctors.trans (hrecs.trans hrules))
+
+/-- Every source family name was fresh before the transaction. -/
+theorem family_fresh (H : AddInductNestedTrace env env' nested)
+    {type : VInductiveType} (htype : type ∈ source.types) :
+    env.constants type.name = none := by
+  have hmem : type.toVConstVal ∈ source.blockTypeConstants :=
+    List.mem_map.2 ⟨type, htype, rfl⟩
+  simpa [VInductDecl.blockTypeConstants] using
+    (ctorFold_spec source.blockTypeConstants H.addTypes).2.2
+      type.toVConstVal hmem
+
+/-- The final environment stores every exact source family constant. -/
+theorem family_lookup (H : AddInductNestedTrace env env' nested)
+    {type : VInductiveType} (htype : type ∈ source.types) :
+    env'.constants type.name = some type.toVConstant := by
+  have hmem : type.toVConstVal ∈ source.blockTypeConstants :=
+    List.mem_map.2 ⟨type, htype, rfl⟩
+  have hlookup :=
+    (ctorFold_spec source.blockTypeConstants H.addTypes).2.1
+      type.toVConstVal hmem
+  have hctors := (ctorFold_spec source.blockConstructorConstants H.addCtors).1
+  have hrecs := (ctorFold_spec nested.recursors H.addRecs).1
+  have hrules : H.recEnv ≤ env' := by
+    simpa only [H.addRules] using
+      (rulesFold_spec nested.generatedRules H.recEnv).1
+  exact (hctors.trans (hrecs.trans hrules)).constants hlookup
+
+/-- Every flattened source constructor name was fresh before the nested
+transaction. -/
+theorem ctor_fresh (H : AddInductNestedTrace env env' nested)
+    {c : VConstVal} (hc : c ∈ source.blockConstructorConstants) :
+    env.constants c.name = none := by
+  have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1
+  have hfresh :=
+    (ctorFold_spec source.blockConstructorConstants H.addCtors).2.2 c hc
+  exact htypes.constants_none hfresh
+
+/-- The final environment stores every exact source constructor
+constant. -/
+theorem ctor_lookup (H : AddInductNestedTrace env env' nested)
+    {type : VInductiveType} (htype : type ∈ source.types)
+    {c : VConstVal} (hc : c ∈ type.ctors) :
+    env'.constants c.name = some c.toVConstant := by
+  have hmem : c ∈ source.blockConstructorConstants :=
+    List.mem_flatMap.2 ⟨type, htype, hc⟩
+  have hlookup :=
+    (ctorFold_spec source.blockConstructorConstants H.addCtors).2.1 c hmem
+  have hrecs := (ctorFold_spec nested.recursors H.addRecs).1
+  have hrules : H.recEnv ≤ env' := by
+    simpa only [H.addRules] using
+      (rulesFold_spec nested.generatedRules H.recEnv).1
+  exact (hrecs.trans hrules).constants hlookup
+
+/-- The final environment stores every restored recursor constant. -/
+theorem rec_lookup (H : AddInductNestedTrace env env' nested)
+    {recursor : VConstVal} (hrec : recursor ∈ nested.recursors) :
+    env'.constants recursor.name = some recursor.toVConstant := by
+  have hlookup := (ctorFold_spec nested.recursors H.addRecs).2.1 recursor hrec
+  have hrules : H.recEnv ≤ env' := by
+    simpa only [H.addRules] using
+      (rulesFold_spec nested.generatedRules H.recEnv).1
+  exact hrules.constants hlookup
+
+/-- Every restored recursor name was fresh before the nested transaction. -/
+theorem rec_fresh (H : AddInductNestedTrace env env' nested)
+    {recursor : VConstVal} (hrec : recursor ∈ nested.recursors) :
+    env.constants recursor.name = none := by
+  have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1
+  have hctors :=
+    (ctorFold_spec source.blockConstructorConstants H.addCtors).1
+  have hfresh := (ctorFold_spec nested.recursors H.addRecs).2.2 recursor hrec
+  exact (htypes.trans hctors).constants_none hfresh
+
+/-- The final environment registers every restored rule. -/
+theorem rule_mem (H : AddInductNestedTrace env env' nested)
+    {df : VDefEq} (hdf : df ∈ nested.generatedRules) :
+    env'.defeqs df := by
+  simpa only [H.addRules] using
+    (rulesFold_spec nested.generatedRules H.recEnv).2 df hdf
+
+end AddInductNestedTrace
+
+nonrec theorem addInductNested_le {source : VInductDecl}
+    {nested : source.NestedBlockChecked}
+    (hadd : addInductNested env nested = some env') : env ≤ env' := by
+  obtain ⟨H⟩ := addInductNested_trace hadd
+  exact H.le
+
+end VEnv
+
+/-- A chained constant package folds into `Ordered` preservation. -/
+theorem NestedConstsWF.fold_ordered :
+    ∀ {cs : List VConstVal} {env env' : VEnv},
+      VEnv.Ordered env → NestedConstsWF env cs →
+      cs.foldlM (fun env c => env.addConst c.name c.toVConstant) env =
+        some env' →
+      VEnv.Ordered env'
+  | [], _, _, h, _, hf => by cases hf; exact h
+  | c :: cs, env, env', h, hwf, hf => by
+    rw [List.foldlM_cons] at hf
+    obtain ⟨env₁, hadd, htail⟩ := Option.bind_eq_some_iff.1 hf
+    exact NestedConstsWF.fold_ordered (.const h hwf.1 hadd)
+      (hwf.2 env₁ hadd) htail
+
+/-- A chained rule package folds into `Ordered` preservation. -/
+theorem NestedRulesWF.fold_ordered :
+    ∀ {dfs : List VDefEq} {env : VEnv},
+      VEnv.Ordered env → NestedRulesWF env dfs →
+      VEnv.Ordered (dfs.foldl VEnv.addDefEq env)
+  | [], _, h, _ => h
+  | df :: dfs, env, h, hwf => by
+    rw [List.foldl_cons]
+    exact NestedRulesWF.fold_ordered (.defeq h hwf.1) hwf.2
+
+/-- `Ordered` preservation for the nested transaction. -/
+theorem VEnv.addInductNested_WF {source : VInductDecl}
+    {nested : source.NestedBlockChecked}
+    (ih : VEnv.Ordered env) (h1 : nested.WF env)
+    (h2 : addInductNested env nested = some env') : VEnv.Ordered env' := by
+  unfold addInductNested at h2
+  obtain ⟨typeEnv, addTypes, h2⟩ := Option.bind_eq_some_iff.1 h2
+  obtain ⟨ctorEnv, addCtors, h2⟩ := Option.bind_eq_some_iff.1 h2
+  obtain ⟨recEnv, addRecs, h2⟩ := Option.bind_eq_some_iff.1 h2
+  cases h2
+  have hT := NestedConstsWF.fold_ordered ih h1.types addTypes
+  have hC := NestedConstsWF.fold_ordered hT (h1.ctors addTypes) addCtors
+  have hR := NestedConstsWF.fold_ordered hC (h1.recs addTypes addCtors) addRecs
+  exact NestedRulesWF.fold_ordered hR (h1.rules addTypes addCtors addRecs)
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/Typing/NestedTransport.lean b/Lean4Lean/Theory/Typing/NestedTransport.lean
new file mode 100644
index 00000000..3ca67118
--- /dev/null
+++ b/Lean4Lean/Theory/Typing/NestedTransport.lean
@@ -0,0 +1,256 @@
+import Lean4Lean.Theory.Typing.NestedInductiveLemmas
+import Lean4Lean.Theory.Typing.Strong
+
+/-!
+# Constant-interpretation substitution (L4L-09C transport, part 1)
+
+The clean compositional substitution σ̂ underlying nested restoration:
+each interpreted constant is replaced by a closed value, level-instantiated
+per occurrence.  The spine-collapsed artifact substitution `restoreExpr`
+is the β-image of σ̂ at fully applied auxiliary heads; the typed transport
+built on σ̂ is the route from the flattened block's staged semantic
+certificate to restored-artifact well-formedness recorded in the L4L-09A
+design note.
+
+This file establishes σ̂, its commutation calculus with lifting,
+instantiation, and level instantiation, context-lookup transport, the
+`ConstInterp` environment morphism, and the typed transport
+`IsDefEq.substConst` with its `HasType`/`IsType`/`VConstant.WF`/
+`VDefEq.WF` corollaries.  The β-collapse bridge from σ̂ to the
+spine-collapsed artifact substitution and the per-phase morphism
+construction for a staged flattened block are the remaining transport
+obligations.
+-/
+
+namespace Lean4Lean
+
+/-- σ̂: replace each interpreted constant by its closed value at the
+occurrence's levels. -/
+def VExpr.substConst (interp : Name → Option VExpr) : VExpr → VExpr
+  | .bvar i => .bvar i
+  | .sort l => .sort l
+  | .const c ls =>
+    match interp c with
+    | some v => v.instL ls
+    | none => .const c ls
+  | .app f a => .app (f.substConst interp) (a.substConst interp)
+  | .lam ty body => .lam (ty.substConst interp) (body.substConst interp)
+  | .forallE ty body => .forallE (ty.substConst interp) (body.substConst interp)
+
+/-- Every interpreted value is closed. -/
+def InterpClosed (interp : Name → Option VExpr) : Prop :=
+  ∀ c v, interp c = some v → v.ClosedN 0
+
+namespace VExpr
+
+variable {interp : Name → Option VExpr}
+
+theorem substConst_liftN (hc : InterpClosed interp) :
+    ∀ (e : VExpr) (k : Nat),
+      (e.liftN n k).substConst interp = (e.substConst interp).liftN n k
+  | .bvar _, _ => rfl
+  | .sort _, _ => rfl
+  | .const c ls, k => by
+    simp only [liftN, substConst]
+    cases h : interp c with
+    | none => simp [liftN]
+    | some v =>
+      exact (((hc c v h).instL (ls := ls)).liftN_eq (Nat.zero_le k)).symm
+  | .app f a, k => by
+    simp only [liftN, substConst, substConst_liftN hc f k,
+      substConst_liftN hc a k]
+  | .lam ty body, k => by
+    simp only [liftN, substConst, substConst_liftN hc ty k,
+      substConst_liftN hc body (k+1)]
+  | .forallE ty body, k => by
+    simp only [liftN, substConst, substConst_liftN hc ty k,
+      substConst_liftN hc body (k+1)]
+
+theorem substConst_lift (hc : InterpClosed interp) (e : VExpr) :
+    (e.lift).substConst interp = (e.substConst interp).lift :=
+  substConst_liftN hc e 0
+
+theorem substConst_instN (hc : InterpClosed interp) :
+    ∀ (e a : VExpr) (k : Nat),
+      (e.inst a k).substConst interp =
+        (e.substConst interp).inst (a.substConst interp) k
+  | .bvar i, a, k => by
+    simp only [inst, substConst]
+    unfold instVar
+    split
+    · simp [substConst]
+    · split
+      · exact (substConst_liftN hc a 0).symm ▸ rfl
+      · simp [substConst]
+  | .sort _, _, _ => rfl
+  | .const c ls, a, k => by
+    simp only [inst, substConst]
+    cases h : interp c with
+    | none => simp [inst]
+    | some v =>
+      exact (((hc c v h).instL (ls := ls)).instN_eq (Nat.zero_le k)).symm
+  | .app f b, a, k => by
+    simp only [inst, substConst, substConst_instN hc f a k,
+      substConst_instN hc b a k]
+  | .lam ty body, a, k => by
+    simp only [inst, substConst, substConst_instN hc ty a k,
+      substConst_instN hc body a (k+1)]
+  | .forallE ty body, a, k => by
+    simp only [inst, substConst, substConst_instN hc ty a k,
+      substConst_instN hc body a (k+1)]
+
+theorem substConst_inst (hc : InterpClosed interp) (e a : VExpr) :
+    (e.inst a).substConst interp =
+      (e.substConst interp).inst (a.substConst interp) :=
+  substConst_instN hc e a 0
+
+theorem substConst_instL :
+    ∀ (e : VExpr),
+      (e.instL ls).substConst interp = ((e.substConst interp).instL ls : VExpr)
+  | .bvar _ => rfl
+  | .sort _ => by simp [instL, substConst]
+  | .const c ls' => by
+    simp only [instL, substConst]
+    cases interp c with
+    | none => simp [instL]
+    | some v => exact (instL_instL).symm
+  | .app f a => by
+    simp only [instL, substConst, substConst_instL f, substConst_instL a]
+  | .lam ty body => by
+    simp only [instL, substConst, substConst_instL ty, substConst_instL body]
+  | .forallE ty body => by
+    simp only [instL, substConst, substConst_instL ty, substConst_instL body]
+
+end VExpr
+
+/-- Context-lookup transport along σ̂. -/
+theorem Lookup.substConst {interp : Name → Option VExpr}
+    (hc : InterpClosed interp) :
+    ∀ {Γ i A}, Lookup Γ i A →
+      Lookup (Γ.map (VExpr.substConst interp)) i (A.substConst interp)
+  | _, _, _, .zero => by
+    rw [List.map_cons, VExpr.substConst_lift hc]
+    exact .zero
+  | _, _, _, .succ h => by
+    rw [List.map_cons, VExpr.substConst_lift hc]
+    exact .succ (h.substConst hc)
+
+namespace VEnv
+
+/-- Environment morphism along a constant interpretation: interpreted
+constants become closed values typed at their σ̂-image types in the target
+environment; surviving constants and registered defeqs are σ̂-imaged.  The
+staged flattened environments of a nested block and their restored
+counterparts form exactly such a morphism, with the auxiliary families,
+constructors, and recursors interpreted by their restoration closures. -/
+structure ConstInterp (E E' : VEnv) (interp : Name → Option VExpr) : Prop where
+  ordered' : VEnv.Ordered E'
+  closed : InterpClosed interp
+  value : ∀ {c ci v}, E.constants c = some ci → interp c = some v →
+    E'.HasType ci.uvars [] v (ci.type.substConst interp)
+  keep : ∀ {c ci}, E.constants c = some ci → interp c = none →
+    E'.constants c = some ⟨ci.uvars, ci.type.substConst interp⟩
+  defeq : ∀ {df}, E.defeqs df →
+    E'.defeqs ⟨df.uvars, df.lhs.substConst interp,
+      df.rhs.substConst interp, df.type.substConst interp⟩
+  structEta : ∀ {rule}, E.structEtas rule → E'.structEtas rule
+  structEta_familyType : ∀ {rule}, E.structEtas rule →
+    ∀ levels,
+      (rule.familyType.instL levels).substConst interp =
+        rule.familyType.instL levels
+  structEta_structureType : ∀ {rule}, E.structEtas rule →
+    ∀ levels params,
+      (rule.structureType levels params).substConst interp =
+        rule.structureType levels (params.map (VExpr.substConst interp))
+  structEta_rebuild : ∀ {rule}, E.structEtas rule →
+    ∀ levels params major,
+      (rule.rebuild levels params major).substConst interp =
+        rule.rebuild levels (params.map (VExpr.substConst interp))
+          (major.substConst interp)
+
+/-- Typed transport along a constant interpretation: every Theory judgment
+of the interpreted environment holds of the σ̂-images in the target
+environment. -/
+theorem IsDefEq.substConst {E E' : VEnv} {interp : Name → Option VExpr}
+    (hi : ConstInterp E E' interp) (H : E.IsDefEq U Γ e1 e2 A) :
+    E'.IsDefEq U (Γ.map (VExpr.substConst interp))
+      (e1.substConst interp) (e2.substConst interp)
+      (A.substConst interp) := by
+  induction H using IsDefEq.rec
+      (motive_2 := fun Γ A es B _ =>
+        E'.SpineWF U (Γ.map (VExpr.substConst interp))
+          (A.substConst interp) (es.map (VExpr.substConst interp))
+          (B.substConst interp)) with
+  | bvar h => exact .bvar (h.substConst hi.closed)
+  | symm _ ih => exact .symm ih
+  | trans _ _ ih1 ih2 => exact .trans ih1 ih2
+  | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3
+  | @constDF c ci ls ls' _ h1 h2 h3 h4 h5 =>
+    rw [VExpr.substConst_instL (e := ci.type)]
+    simp only [VExpr.substConst]
+    cases hv : interp c with
+    | none => exact .constDF (hi.keep h1 hv) h2 h3 h4 h5
+    | some v =>
+      have hval := hi.value h1 hv
+      have hnil : OnCtx ([] : List VExpr) (E'.IsType ci.uvars) := trivial
+      have hcore := hval.instL_r hi.ordered' hnil h2 h3 h5
+      exact hcore.weak0 hi.ordered'
+  | appDF _ _ ih1 ih2 =>
+    exact (VExpr.substConst_inst hi.closed ..).symm ▸ .appDF ih1 ih2
+  | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2
+  | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2
+  | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2
+  | beta _ _ ih1 ih2 =>
+    simpa [VExpr.substConst, VExpr.substConst_inst hi.closed] using
+      VEnv.IsDefEq.beta ih1 ih2
+  | eta _ ih =>
+    simpa [VExpr.substConst, VExpr.substConst_lift hi.closed] using
+      VEnv.IsDefEq.eta ih
+  | structEta hreg hlevels hlevelsLength hparamsLength _ _ _
+      ihSpine ihMajor ihRebuild =>
+    rw [hi.structEta_familyType hreg] at ihSpine
+    rw [hi.structEta_structureType hreg] at ihMajor
+    rw [hi.structEta_rebuild hreg,
+      hi.structEta_structureType hreg] at ihRebuild
+    have hout := VEnv.IsDefEq.structEta (hi.structEta hreg) hlevels
+      hlevelsLength (by simpa using hparamsLength)
+      (by simpa [VExpr.substConst] using ihSpine)
+      ihMajor ihRebuild
+    simpa only [hi.structEta_rebuild hreg,
+      hi.structEta_structureType hreg] using hout
+  | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
+  | extra h1 h2 h3 =>
+    simpa [VExpr.substConst_instL] using
+      VEnv.IsDefEq.extra (env := E') (hi.defeq h1) h2 (by simpa using h3)
+  | nil => exact .nil
+  | cons _ _ ihType ihRest =>
+    exact .cons ihType (by
+      simpa only [VExpr.substConst_inst hi.closed] using ihRest)
+
+theorem HasType.substConst {E E' : VEnv} {interp : Name → Option VExpr}
+    (hi : ConstInterp E E' interp) (H : E.HasType U Γ e A) :
+    E'.HasType U (Γ.map (VExpr.substConst interp))
+      (e.substConst interp) (A.substConst interp) :=
+  IsDefEq.substConst hi H
+
+theorem IsType.substConst {E E' : VEnv} {interp : Name → Option VExpr}
+    (hi : ConstInterp E E' interp) (H : E.IsType U Γ A) :
+    E'.IsType U (Γ.map (VExpr.substConst interp)) (A.substConst interp) :=
+  let ⟨_, h⟩ := H; ⟨_, IsDefEq.substConst hi h⟩
+
+end VEnv
+
+/-- Constant well-formedness transports to the σ̂-image constant. -/
+theorem VConstant.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr}
+    {ci : VConstant} (hi : VEnv.ConstInterp E E' interp) (H : ci.WF E) :
+    VConstant.WF E' ⟨ci.uvars, ci.type.substConst interp⟩ :=
+  VEnv.IsType.substConst hi H
+
+/-- Rule well-formedness transports to the σ̂-image rule. -/
+theorem VDefEq.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr}
+    {df : VDefEq} (hi : VEnv.ConstInterp E E' interp) (H : df.WF E) :
+    VDefEq.WF E' ⟨df.uvars, df.lhs.substConst interp,
+      df.rhs.substConst interp, df.type.substConst interp⟩ :=
+  ⟨VEnv.IsDefEq.substConst hi H.1, VEnv.IsDefEq.substConst hi H.2⟩
+
+end Lean4Lean
diff --git a/Lean4Lean/Theory/Typing/Pattern.lean b/Lean4Lean/Theory/Typing/Pattern.lean
index 87e77492..44faa7f6 100644
--- a/Lean4Lean/Theory/Typing/Pattern.lean
+++ b/Lean4Lean/Theory/Typing/Pattern.lean
@@ -9,7 +9,7 @@ inductive Pattern where
   | app (f a : Pattern)
   | var (f : Pattern)
 
-def Pattern.varN (p : Pattern) : Nat → Pattern
+@[reducible] def Pattern.varN (p : Pattern) : Nat → Pattern
   | 0 => p
   | n+1 => (p.varN n).var
 
@@ -19,7 +19,7 @@ inductive Subpattern (p : Pattern) : Pattern → Prop where
   | appR : Subpattern p a → Subpattern p (.app f a)
   | varL : Subpattern p f → Subpattern p (.var f)
 
-def Subpattern.varN (h : Subpattern p f) : ∀ {n}, Subpattern p (.varN f n)
+theorem Subpattern.varN (h : Subpattern p f) : ∀ {n}, Subpattern p (.varN f n)
   | 0 => h
   | _+1 => .varL (.varN h)
 
@@ -70,7 +70,7 @@ inductive Pattern.LE : Pattern → Pattern → Prop where
   | app : LE f f' → LE a a' → LE (.app f a) (.app f' a')
   | app_var : LE f f' → LE (.app f a) (.var f')
 
-def Pattern.Path : Pattern → Type
+@[reducible] def Pattern.Path : Pattern → Type
   | .const _ => Empty
   | .app f a => f.Path ⊕ a.Path
   | .var f => Option f.Path
@@ -164,6 +164,22 @@ theorem Pattern.matches_instN {p : Pattern} {e : VExpr} {m1 m2} (H : p.Matches e
     rw [(_ : (fun _ => _) = _)]; exact ih1.app ih2
     ext (_|_) <;> rfl
 
+/-- Universe instantiation preserves a successful match.  The universe
+capture is instantiated pointwise and every expression capture is
+instantiated by the same level substitution. -/
+theorem Pattern.Matches.instL {p : Pattern} {e : VExpr} {m1 m2}
+    (H : p.Matches e m1 m2) (ls : List VLevel) :
+    p.Matches (e.instL ls) (m1.map (VLevel.inst ls))
+      fun x => (m2 x).instL ls := by
+  induction H with
+  | const => erw [show (fun _ : Empty => _) = _ by ext ⟨⟩]; exact .const
+  | var _ ih =>
+    rw [(_ : (fun _ => _) = _)]; exact ih.var
+    ext (_|_) <;> rfl
+  | app _ _ ih1 ih2 =>
+    rw [(_ : (fun _ => _) = _)]; exact ih1.app ih2
+    ext (_|_) <;> rfl
+
 theorem Pattern.matches_inter {p q : Pattern} {e : VExpr} :
     (∃ m1 m2, p.Matches e m1 m2) ∧ (∃ m1 m2, q.Matches e m1 m2) ↔
     (∃ r m1 m2, p.inter q = some r ∧ r.Matches e m1 m2) := by
@@ -227,6 +243,218 @@ inductive SimplePattern where
   | iota (recursor : Name) (major : Nat) (constr : Name) (args : Nat)
   | defn (head : Name)
 
-def SimplePattern.toPattern : SimplePattern → Pattern
+@[reducible] def SimplePattern.toPattern : SimplePattern → Pattern
   | .defn c => .const c
   | .iota r m c n => .app (.varN (.const r) m) (.varN (.const c) n)
+
+/-! ## Shape helpers for generated recursor patterns
+
+`HeadConstN`, `HeadConst`, `of_varN_matches`, `RecursorIotaPattern`, and
+`matches_shape` form the implementation-independent shape layer consumed by
+the generated iota patterns of a certified inductive block
+(`Theory/Typing/InductivePattern.lean`). They characterize matching against
+`Pattern.varN` towers and `SimplePattern.iota` patterns without referring to
+any generator data. -/
+
+/-- `HeadConstN c ls n e`: `e` is the constant `c` at levels `ls` applied to
+exactly `n` arguments. This is the expression shape captured by matching the
+pattern `Pattern.varN (.const c) n`. -/
+inductive HeadConstN (c : Name) (ls : List VLevel) : Nat → VExpr → Prop where
+  | const : HeadConstN c ls 0 (.const c ls)
+  | app : HeadConstN c ls n f → HeadConstN c ls (n+1) (.app f a)
+
+/-- `e` is an application spine headed by the constant `c`. -/
+def HeadConst (c : Name) (e : VExpr) : Prop := ∃ ls n, HeadConstN c ls n e
+
+/-- Matching a `varN` tower of a constant captures exactly a `HeadConstN`
+spine whose head levels are the pattern's level assignment. -/
+theorem Pattern.of_varN_matches {c : Name} :
+    ∀ {n : Nat} {e : VExpr} {m2}, (Pattern.varN (.const c) n).Matches e m1 m2 →
+      HeadConstN c m1 n e := by
+  intro n
+  induction n with
+  | zero => intro e m2 H; cases H; exact .const
+  | succ n ih => intro e m2 H; cases H with | var h => exact .app (ih h)
+
+/-- Every `HeadConstN` spine matches its `varN` tower. -/
+theorem HeadConstN.matches : HeadConstN c ls n e →
+    ∃ m2, (Pattern.varN (.const c) n).Matches e ls m2
+  | .const => ⟨_, .const⟩
+  | .app h => let ⟨_, h'⟩ := h.matches; ⟨_, .var h'⟩
+
+/-- The capture paths of an `n`-ary `varN` tower in argument order (outermost
+application first): matching assigns the `t`-th entry the `t`-th spine
+argument. -/
+def Pattern.varNPaths (p : Pattern) : ∀ n, List (Pattern.Path (p.varN n))
+  | 0 => []
+  | n+1 => (varNPaths p n).map some ++ [none]
+
+@[simp] theorem Pattern.varNPaths_length (p : Pattern) :
+    ∀ n, (varNPaths p n).length = n
+  | 0 => rfl
+  | n+1 => by
+    show ((varNPaths p n).map some ++ [none]).length = n + 1
+    rw [List.length_append, List.length_map, varNPaths_length p n]; rfl
+
+/-- The exact pattern of one generated iota rule: the recursor constant
+applied to `major` arguments (parameters, motives, minors, and the
+constructor's result indices), with a `ctor`-headed major premise carrying
+`args` arguments. Definitionally `(SimplePattern.iota recursor major ctor
+args).toPattern`. -/
+def RecursorIotaPattern (recursor : Name) (major : Nat)
+    (ctor : Name) (args : Nat) : Pattern :=
+  .app (.varN (.const recursor) major) (.varN (.const ctor) args)
+
+theorem SimplePattern.toPattern_iota :
+    (SimplePattern.iota r m c n).toPattern = RecursorIotaPattern r m c n := rfl
+
+/-- Match inversion for an iota pattern: the expression is exactly a
+recursor-headed spine at the pattern's level assignment whose last argument
+is a constructor-headed spine (at unconstrained levels). -/
+theorem RecursorIotaPattern.matches_shape
+    (H : (RecursorIotaPattern r mj c n).Matches e m1 m2) :
+    ∃ f a ls, e = .app f a ∧ HeadConstN r m1 mj f ∧ HeadConstN c ls n a := by
+  cases H with
+  | app h1 h2 =>
+    exact ⟨_, _, _, rfl, Pattern.of_varN_matches h1, Pattern.of_varN_matches h2⟩
+
+/-- Match construction for an iota pattern from the two head spines. -/
+theorem RecursorIotaPattern.matches_of
+    (h1 : HeadConstN r ls mj f) (h2 : HeadConstN c ls' n a) :
+    ∃ m2, (RecursorIotaPattern r mj c n).Matches (.app f a) ls m2 :=
+  let ⟨_, hf⟩ := h1.matches
+  let ⟨_, ha⟩ := h2.matches
+  ⟨_, .app hf ha⟩
+
+/-- Subpatterns of a constant `varN` tower are exactly its shorter towers. -/
+theorem Subpattern.varN_const_le :
+    ∀ {n}, Subpattern p (Pattern.varN (.const c) n) →
+      ∃ j, j ≤ n ∧ p = Pattern.varN (.const c) j := by
+  intro n
+  induction n with
+  | zero => intro H; cases H; exact ⟨0, Nat.le_refl _, rfl⟩
+  | succ n ih =>
+    intro H
+    cases H with
+    | refl => exact ⟨n+1, Nat.le_refl _, rfl⟩
+    | varL h =>
+      let ⟨j, hj, hp⟩ := ih h
+      exact ⟨j, Nat.le_succ_of_le hj, hp⟩
+
+/-- Subpattern classification for an iota pattern: the whole pattern, a
+prefix of the recursor head, or a prefix of the constructor spine. -/
+theorem RecursorIotaPattern.subpattern_inv
+    (H : Subpattern p (RecursorIotaPattern r mj c n)) :
+    p = RecursorIotaPattern r mj c n ∨
+      (∃ j, j ≤ mj ∧ p = .varN (.const r) j) ∨
+      (∃ j, j ≤ n ∧ p = .varN (.const c) j) := by
+  cases H with
+  | refl => exact .inl rfl
+  | appL h => exact .inr (.inl h.varN_const_le)
+  | appR h => exact .inr (.inr h.varN_const_le)
+
+/-- Two constant `varN` towers intersect only when they agree exactly. -/
+theorem Pattern.varN_const_inter_some :
+    ∀ {n n' p}, (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = some p →
+      c = c' ∧ n = n' ∧ p = Pattern.varN (.const c) n := by
+  intro n
+  induction n with
+  | zero =>
+    intro n' p h
+    cases n' with
+    | zero =>
+      simp [Pattern.varN, Pattern.inter] at h
+      exact ⟨h.1, rfl, h.2.symm⟩
+    | succ n' => simp [Pattern.varN, Pattern.inter] at h
+  | succ n ih =>
+    intro n' p h
+    cases n' with
+    | zero => simp [Pattern.varN, Pattern.inter] at h
+    | succ n' =>
+      simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff,
+        Option.pure_def, Option.some.injEq] at h
+      obtain ⟨q, hq, rfl⟩ := h
+      obtain ⟨rfl, rfl, rfl⟩ := ih hq
+      exact ⟨rfl, rfl, rfl⟩
+
+theorem Pattern.varN_const_inter_of_ne_name (h : c ≠ c') (n n' : Nat) :
+    (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by
+  cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with
+  | none => rfl
+  | some p => exact absurd (varN_const_inter_some e).1 h
+
+theorem Pattern.varN_const_inter_of_ne_arity (h : n ≠ n') (c c' : Name) :
+    (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by
+  cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with
+  | none => rfl
+  | some p => exact absurd (varN_const_inter_some e).2.1 h
+
+/-- An application pattern intersects a constant `varN` tower only through a
+positive tower whose inner tower intersects the function part. -/
+theorem Pattern.app_inter_varN_const_some {f a : Pattern}
+    (h : (Pattern.app f a).inter (Pattern.varN (.const c) n) = some p) :
+    ∃ n' q, n = n' + 1 ∧ f.inter (Pattern.varN (.const c) n') = some q ∧
+      p = .app q a := by
+  cases n with
+  | zero => simp [Pattern.varN, Pattern.inter] at h
+  | succ n' =>
+    simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff,
+      Option.pure_def, Option.some.injEq] at h
+    obtain ⟨q, hq, rfl⟩ := h
+    exact ⟨n', q, rfl, hq, rfl⟩
+
+/-- Two iota patterns intersect only when they agree exactly. -/
+theorem RecursorIotaPattern.inter_some
+    (h : (RecursorIotaPattern r mj c n).inter (RecursorIotaPattern r' mj' c' n') = some p) :
+    r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' ∧ p = RecursorIotaPattern r mj c n := by
+  simp only [RecursorIotaPattern, Pattern.inter, bind, Option.bind_eq_some_iff,
+    Option.pure_def, Option.some.injEq] at h
+  obtain ⟨q1, h1, q2, h2, rfl⟩ := h
+  obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h1
+  obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h2
+  exact ⟨rfl, rfl, rfl, rfl, rfl⟩
+
+/-- An iota pattern intersects a constant `varN` tower only at a tower whose
+inner arity is the pattern's major arity with the recursor's name. -/
+theorem RecursorIotaPattern.inter_varN_const_some
+    (h : (RecursorIotaPattern r mj c n).inter (Pattern.varN (.const b) j) = some p) :
+    b = r ∧ j = mj + 1 := by
+  obtain ⟨j', q, rfl, hq, rfl⟩ := Pattern.app_inter_varN_const_some h
+  obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some hq
+  exact ⟨rfl, rfl⟩
+
+/-- Constant `varN` towers are injective in the head name and the arity. -/
+theorem Pattern.varN_const_inj {c c' : Name} :
+    ∀ {n n' : Nat}, Pattern.varN (.const c) n = Pattern.varN (.const c') n' →
+      c = c' ∧ n = n'
+  | 0, 0, h => by cases h; exact ⟨rfl, rfl⟩
+  | 0, n'+1, h => absurd h (by simp [Pattern.varN])
+  | n+1, 0, h => absurd h (by simp [Pattern.varN])
+  | n+1, n'+1, h => by
+    injection h with h1
+    obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1
+    exact ⟨rfl, rfl⟩
+
+/-- Iota patterns are injective in all four components. -/
+theorem RecursorIotaPattern.inj
+    (h : RecursorIotaPattern r mj c n = RecursorIotaPattern r' mj' c' n') :
+    r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' := by
+  injection h with h1 h2
+  obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1
+  obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h2
+  exact ⟨rfl, rfl, rfl, rfl⟩
+
+/-- The only application subpattern of an iota pattern is the pattern
+itself. -/
+theorem RecursorIotaPattern.app_subpattern
+    (H : Subpattern (.app p₁ p₂) (RecursorIotaPattern r mj c n)) :
+    p₁ = .varN (.const r) mj ∧ p₂ = .varN (.const c) n := by
+  rcases RecursorIotaPattern.subpattern_inv H with heq | ⟨j, hj, heq⟩ | ⟨j, hj, heq⟩
+  · injection heq with h1 h2; exact ⟨h1, h2⟩
+  · cases j <;> exact absurd heq (by simp [Pattern.varN])
+  · cases j <;> exact absurd heq (by simp [Pattern.varN])
+
+/-- Apply an RHS template head to a list of template arguments. -/
+def Pattern.RHS.appN {p : Pattern} (f : p.RHS) : List p.RHS → p.RHS
+  | [] => f
+  | a :: as => Pattern.RHS.appN (.app f a) as
diff --git a/Lean4Lean/Theory/Typing/Strong.lean b/Lean4Lean/Theory/Typing/Strong.lean
index 368aa47a..53eb704a 100644
--- a/Lean4Lean/Theory/Typing/Strong.lean
+++ b/Lean4Lean/Theory/Typing/Strong.lean
@@ -71,6 +71,20 @@ inductive IsDefEqStrong : List VExpr → VExpr → VExpr → VExpr → Prop wher
     A::Γ ⊢ e.lift : .forallE A.lift (B.liftN 1 1) →
     A::Γ ⊢ A.lift : .sort u →
     Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B
+  | structEta :
+    env.structEtas rule →
+    (∀ level ∈ levels, level.WF uvars) →
+    levels.length = rule.uvars →
+    params.length = rule.nparams →
+    env.SpineWF uvars Γ (rule.familyType.instL levels)
+      params (.sort resultLevel) →
+    u.WF uvars →
+    Γ ⊢ rule.structureType levels params : .sort u →
+    Γ ⊢ major : rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major :
+      rule.structureType levels params →
+    Γ ⊢ rule.rebuild levels params major ≡ major :
+      rule.structureType levels params
   | proofIrrel :
     Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p →
     Γ ⊢ h ≡ h' : p
@@ -173,6 +187,22 @@ theorem IsDefEqStrong.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEqStrong U
       rwa [← lift_liftN', ← lift_liftN'] at ih5
     · have ih6 := ih6 W.succ
       rwa [← lift_liftN'] at ih6
+  | @structEta rule levels _ params _ u major hreg hlevels
+      hlevelsLength hparamsLength hparamsSpine hu _ _ _ ihType ihMajor ihRebuild =>
+    have hparamsSpine' := hparamsSpine.weakN henv W
+    rw [(henv.structEtaWF hreg).familyType_closed.instL.liftN_eq
+      (Nat.zero_le _)] at hparamsSpine'
+    have htype := ihType W
+    rw [VStructEta.structureType_liftN] at htype
+    have hmajor := ihMajor W
+    rw [VStructEta.structureType_liftN] at hmajor
+    have hrebuild := ihRebuild W
+    rw [VStructEta.rebuild_liftN rule levels params major
+      hparamsLength n k, VStructEta.structureType_liftN] at hrebuild
+    have hout := IsDefEqStrong.structEta hreg hlevels hlevelsLength
+      (by simpa using hparamsLength) hparamsSpine' hu htype hmajor hrebuild
+    simpa only [VStructEta.rebuild_liftN rule levels params major
+      hparamsLength n k, VStructEta.structureType_liftN] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W)
   | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 =>
     have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
@@ -195,6 +225,10 @@ theorem IsDefEqStrong.defeq (H : IsDefEqStrong env U Γ e1 e2 A) : env.IsDefEq U
   | defeqDF _ _ _ ih1 ih2 => exact .defeqDF ih1 ih2
   | beta _ _ _ _ _ _ _ _ _ _ ih1 ih2 => exact .beta ih1 ih2
   | eta _ _ _ _ _ _ _ _ _ _ _ ih => exact .eta ih
+  | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      _ _ _ _ _ ihMajor ihRebuild =>
+    exact .structEta hreg hlevels hlevelsLength hparamsLength
+      hparamsSpine ihMajor ihRebuild
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
   | extra h1 h2 h3 => exact .extra h1 h2 h3
 
@@ -214,6 +248,10 @@ theorem IsDefEqStrong.mono
   | defeqDF h1 _ _ ih1 ih2 => exact .defeqDF h1 ih1 ih2
   | beta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 => exact .beta h1 h2 ih1 ih2 ih3 ih4 ih5 ih6
   | eta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 => exact .eta h1 h2 ih1 ih2 ih3 ih4 ih5 ih6
+  | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      hu _ _ _ ihType ihMajor ihRebuild =>
+    exact .structEta (henv.structEtas hreg) hlevels hlevelsLength
+      hparamsLength (hparamsSpine.mono henv) hu ihType ihMajor ihRebuild
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3
   | extra h1 h2 h3 h4 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
     exact .extra (henv.2 h1) h2 h3 h4 ih1 ih2 ih3 ih4 ih5
@@ -257,6 +295,8 @@ theorem EqUpToLevels.instL (H : env.IsDefEqStrong U' Γ e1 e2 A) :
   | defeqDF _ _ _ _ ih => exact ih
   | beta _ _ _ _ _ _ _ _ ih1 _ ih3 ih4 _ ih6 => exact ⟨.app (.lam ih1.1 ih3.1) ih4.1, ih6.2⟩
   | eta _ _ _ _ _ _ _ _ ih1 _ _ ih4 ih5 => exact ⟨.lam ih1.1 (.app ih5.1 .bvar), ih4.1⟩
+  | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    exact ⟨ihRebuild.1, ihMajor.2⟩
 
 
 variable! {env : VEnv} (W : OnCtx Γ fun _ A => A.LevelWF U) in
@@ -327,6 +367,24 @@ theorem IsDefEqStrong.instL (H : env.IsDefEqStrong U Γ e1 e2 A) :
     simpa [VExpr.instL] using .eta (.inst hls) (.inst hls) ih1 ih2
       (by simpa [VExpr.instL] using ih3) ih4
       (by simpa [VExpr.instL] using ih5) (by simpa [VExpr.instL] using ih6)
+  | @structEta rule levels _ params _ u major hreg hlevels
+      hlevelsLength hparamsLength hparamsSpine _ _ _ _ ihType ihMajor ihRebuild =>
+    have hlevels' : ∀ level ∈ levels.map (VLevel.inst ls),
+        level.WF U' := by
+      intro level hlevel
+      obtain ⟨source, _, heq⟩ := List.mem_map.1 hlevel
+      rw [← heq]
+      exact VLevel.WF.inst hls
+    rw [VStructEta.structureType_instL] at ihType ihMajor
+    rw [VStructEta.rebuild_instL,
+      VStructEta.structureType_instL] at ihRebuild
+    have hparamsSpine' := hparamsSpine.instL hls
+    rw [VExpr.instL_instL] at hparamsSpine'
+    have hout := IsDefEqStrong.structEta hreg hlevels'
+      (by simpa using hlevelsLength) (by simpa using hparamsLength)
+      hparamsSpine' (VLevel.WF.inst hls) ihType ihMajor ihRebuild
+    simpa only [VStructEta.rebuild_instL,
+      VStructEta.structureType_instL] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 =>
     exact .proofIrrel ih1 ih2 ih3
   | extra h1 h2 h3 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 =>
@@ -410,6 +468,22 @@ theorem IsDefEqStrong.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.
         (by simpa [inst, ← lift_instN_lo] using ih6 W.succ hΓ')
     rw [lift, liftN_instN_lo (hj := Nat.zero_le _), Nat.add_comm] at this
     simpa [inst]
+  | @structEta rule levels _ params _ u major hreg hlevels
+      hlevelsLength hparamsLength hparamsSpine hu _ _ _ ihType ihMajor ihRebuild =>
+    have hparamsSpine' := SpineWF.instN henv W h₀.defeq hparamsSpine
+    rw [(henv.structEtaWF hreg).familyType_closed.instL.instN_eq
+      (Nat.zero_le _)] at hparamsSpine'
+    have htype := ihType W hΓ
+    rw [VStructEta.structureType_instN] at htype
+    have hmajor := ihMajor W hΓ
+    rw [VStructEta.structureType_instN] at hmajor
+    have hrebuild := ihRebuild W hΓ
+    rw [VStructEta.rebuild_instN rule levels params major e₀
+      hparamsLength k, VStructEta.structureType_instN] at hrebuild
+    have hout := IsDefEqStrong.structEta hreg hlevels hlevelsLength
+      (by simpa using hparamsLength) hparamsSpine' hu htype hmajor hrebuild
+    simpa only [VStructEta.rebuild_instN rule levels params major e₀
+      hparamsLength k, VStructEta.structureType_instN] using hout
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W hΓ) (ih2 W hΓ) (ih3 W hΓ)
   | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 =>
     have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1
@@ -460,6 +534,10 @@ theorem IsDefEqStrong.forallE_inv' (hΓ : CtxStrong env U Γ)
   | eta _ _ _ _ _ _ _ _ _ _ _ ih =>
     obtain ⟨⟨⟩⟩ | eq := eq
     exact ih hΓ (.inl eq)
+  | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    obtain eq | eq := eq
+    · exact ihRebuild hΓ (.inl eq)
+    · exact ihMajor hΓ (.inl eq)
   | @extra df ls _ Γ h1 h2 =>
     suffices ∀ e, VExpr.instL ls e = VExpr.forallE A B →
         EnvStrong env df.uvars e df.type →
@@ -498,6 +576,8 @@ theorem IsDefEqStrong.isType' (hΓ : CtxStrong env U Γ) (H : env.IsDefEqStrong
   | defeqDF _ h2 => exact ⟨_, h2.hasType.2⟩
   | beta _ _ _ h4 _ h6 => exact ⟨_, h6.hasType.1.instN henv hΓ .zero h4 hΓ⟩
   | eta _ _ _ _ _ _ _ _ _ _ _ ih => exact ih hΓ
+  | @structEta _ _ _ _ _ u _ _ _ _ _ _ _ htype _ _ _ _ _ =>
+    exact ⟨u, htype⟩
   | proofIrrel h1 => exact ⟨_, h1⟩
   | extra h1 h2 =>
     have ⟨_, h⟩ := (envIH.2 h1).2.2.1
@@ -601,6 +681,14 @@ theorem EqUpToLevels.defeq (H : env.IsDefEqStrong U Γ e1 e2 A)
       (.symm <| .lamDF h1 h2 c1.symm h4 (.defeqDF_l henv W c1.symm h4) c3.symm
         (.defeqDF_l henv W c1.symm c3.symm)) ?_
     exact .trans (.eta h1 h2 h3 h4 h5 h6 h7 h8) (ih4 W (EqUpToLevels.refl W.levelWF h6).1 H2)
+  | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine hu htype hmajor
+      hrebuild _ ihMajor ihRebuild =>
+    have hrebuildRefl := (EqUpToLevels.refl W.levelWF hrebuild).2
+    have hmajorRefl := (EqUpToLevels.refl W.levelWF hmajor).1
+    exact (ihRebuild W H1 hrebuildRefl).trans <|
+      (IsDefEqStrong.structEta hreg hlevels hlevelsLength hparamsLength
+        hparamsSpine hu htype hmajor hrebuild).trans
+      (ihMajor W hmajorRefl H2)
   | proofIrrel h1 _ _ _ ih1 ih2 => exact .proofIrrel h1 (ih1 W H1 H1) (ih2 W H2 H2)
   | extra h1 h2 h3 h4 h5 h6 h7 h8 h9 _ ih1 ih2 =>
     have c1 := ih1 trivial H1 (EqUpToLevels.refl (by trivial) h6).2
@@ -613,7 +701,8 @@ theorem IsDefEq.strong' (hΓ : CtxStrong env U Γ)
     (H : env.IsDefEq U Γ e1 e2 A) : env.IsDefEqStrong U Γ e1 e2 A := by
   have hctx {Γ} (H : OnCtx Γ fun Γ A => ∃ u, env.IsDefEqStrong U Γ A A (.sort u)) :
      OnCtx Γ (env.IsType U) := H.mono fun ⟨_, h⟩ => ⟨_, h.defeq⟩
-  induction H with
+  induction H using IsDefEq.rec
+      (motive_2 := fun _ _ _ _ _ => True) with
   | bvar h =>
     let ⟨u, hA⟩ := hΓ.lookup henv h
     exact .bvar h (hA.defeq.sort_r henv (hctx hΓ)) hA
@@ -660,11 +749,19 @@ theorem IsDefEq.strong' (hΓ : CtxStrong env U Γ)
     have hΓ' : CtxStrong env U (_::_) := ⟨hΓ, _, hA⟩
     exact .eta (hA.defeq.sort_r henv hΓ.defeq) (hB.defeq.sort_r henv hΓ'.defeq)
       hA hB (hB.weakN henv (.succ .one)) he (he.weakN henv .one) (hA.weakN henv .one)
+  | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine
+      _ _ _ ihMajor ihRebuild =>
+    have hmajor := ihMajor hΓ
+    have hrebuild := ihRebuild hΓ
+    let ⟨u, htype⟩ := hmajor.isType' henv envIH hΓ
+    exact .structEta hreg hlevels hlevelsLength hparamsLength
+      hparamsSpine (htype.defeq.sort_r henv hΓ.defeq) htype hmajor hrebuild
   | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 hΓ) (ih2 hΓ) (ih3 hΓ)
   | extra h1 h2 h3 =>
     let ⟨⟨hl, ⟨_, ht⟩, _⟩, hr, _, _⟩ := envIH.2 h1
     exact .extra h1 h2 h3 (.inst h2) (ht.instL h2)
       (hl.instL h2) (hr.instL h2) ((hl.instL h2).weak0 henv) ((hr.instL h2).weak0 henv)
+  | nil | cons => trivial
 
 theorem CtxStrong.strong' (henv : Ordered env) (envIH : env.OnTypes (EnvStrong env))
     (hΓ : OnCtx Γ (env.IsType U)) : CtxStrong env U Γ := by
@@ -743,6 +840,8 @@ theorem IsDefEqStrong.hasType' {env : VEnv}
     rw [instN_bvar0] at this; specialize this ih2.1
     refine ⟨.base <| .lam h1 h2 ih1.1 ih2.1 (.base this) ?_, ih4.1⟩
     exact .base <| .forallE h1 h2 ih1.1 ih2.1
+  | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild =>
+    exact ⟨ihRebuild.1, ihMajor.1⟩
   | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 => exact ⟨ih4.1, ih5.1⟩
 
 theorem HasTypeStrong.refl {env : VEnv}
diff --git a/Lean4Lean/Theory/Typing/UniqueTyping.lean b/Lean4Lean/Theory/Typing/UniqueTyping.lean
index 90162770..13ed6c39 100644
--- a/Lean4Lean/Theory/Typing/UniqueTyping.lean
+++ b/Lean4Lean/Theory/Typing/UniqueTyping.lean
@@ -267,6 +267,95 @@ variable! (henv : VEnv.WF env) (hΓ : OnCtx Γ' (env.IsType U)) in
 theorem _root_.Lean4Lean.VExpr.WF.weak'_iff (W : Ctx.Lift' l Γ Γ') :
     VExpr.WF env U Γ' (e.lift' l) ↔ VExpr.WF env U Γ e := IsDefEqU.weak'_iff henv hΓ W
 
+/-! ### Application-spine weakening and inversion -/
+
+/-- General context weakening for an application spine. -/
+theorem SpineWF.weak' {env : VEnv} (henv : env.Ordered)
+    {U : Nat} {lift : Lift} {Γ Γ' : List VExpr}
+    (W : Ctx.Lift' lift Γ Γ') :
+    ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B →
+      env.SpineWF U Γ' (A.lift' lift)
+        (es.map fun e => e.lift' lift) (B.lift' lift) := by
+  intro es
+  induction es with
+  | nil =>
+      intro A B h
+      cases h
+      exact .nil
+  | cons e es ih =>
+      intro A B h
+      obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h.cons_inv
+      refine .cons (he.weak' henv W) ?_
+      have weakened := ih hrest
+      rwa [VExpr.lift'_inst_hi] at weakened
+
+/-- Invert weakening of every component of an application-spine judgment
+when the enlarged context is well formed. -/
+theorem SpineWF.weakN_inv {env : VEnv} {U n k : Nat} {Γ Γ' : List VExpr}
+    (henv : env.WF) (hΓ' : OnCtx Γ' (env.IsType U))
+    (W : Ctx.LiftN n k Γ Γ') :
+    ∀ {es : List VExpr} {A B : VExpr},
+      env.SpineWF U Γ' (A.liftN n k)
+        (es.map fun e => e.liftN n k) (B.liftN n k) →
+      env.SpineWF U Γ A es B := by
+  intro es
+  induction es with
+  | nil =>
+      intro A B h
+      have hab := VExpr.liftN_inj.1 h.nil_inv
+      subst B
+      exact .nil
+  | cons e es ih =>
+      intro A B h
+      obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h.cons_inv
+      cases A with
+      | bvar index => cases sourceEq
+      | sort level => cases sourceEq
+      | const name levels => cases sourceEq
+      | app fn argument => cases sourceEq
+      | lam domain body => cases sourceEq
+      | forallE A₁ A₂ =>
+        injection sourceEq with domainEq bodyEq
+        subst A₁'
+        subst A₂'
+        refine .cons ((HasType.weakN_iff henv hΓ' W).1 he) ?_
+        rw [← VExpr.liftN_inst_hi] at hrest
+        exact ih hrest
+
+/-- Invert a general context lift componentwise across an application-spine
+judgment. -/
+theorem SpineWF.weak'_inv {env : VEnv} {U : Nat} {lift : Lift}
+    {Γ Γ' : List VExpr}
+    (henv : env.WF) (hΓ' : OnCtx Γ' (env.IsType U))
+    (W : Ctx.Lift' lift Γ Γ') :
+    ∀ {es : List VExpr} {A B : VExpr},
+      env.SpineWF U Γ' (A.lift' lift)
+        (es.map fun e => e.lift' lift) (B.lift' lift) →
+      env.SpineWF U Γ A es B := by
+  intro es
+  induction es with
+  | nil =>
+      intro A B h
+      have hab := VExpr.lift'_inj.1 h.nil_inv
+      subst B
+      exact .nil
+  | cons e es ih =>
+      intro A B h
+      obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h.cons_inv
+      cases A with
+      | bvar index => cases sourceEq
+      | sort level => cases sourceEq
+      | const name levels => cases sourceEq
+      | app fn argument => cases sourceEq
+      | lam domain body => cases sourceEq
+      | forallE A₁ A₂ =>
+        injection sourceEq with domainEq bodyEq
+        subst A₁'
+        subst A₂'
+        refine .cons ((HasType.weak'_iff henv hΓ' W).1 he) ?_
+        rw [← VExpr.lift'_inst_hi] at hrest
+        exact ih hrest
+
 variable! (henv : VEnv.WF env) in
 theorem _root_.Lean4Lean.OnCtx.weak'_inv
     (W : Ctx.Lift' ρ Γ Γ') (H : OnCtx Γ' (env.IsType U)) : OnCtx Γ (env.IsType U) := by
diff --git a/Lean4Lean/Theory/VDecl.lean b/Lean4Lean/Theory/VDecl.lean
index 1dfdea0e..f6825406 100644
--- a/Lean4Lean/Theory/VDecl.lean
+++ b/Lean4Lean/Theory/VDecl.lean
@@ -20,12 +20,10 @@ structure VInductDecl where
   types : List VInductiveType
 
 inductive VDecl where
-  /-- Reserve a constant name, which cannot be used in expressions.
-  Used to represent unsafe declarations in safe mode -/
-  | block (n : Name)
   | axiom (_ : VConstVal)
   | def (_ : VDefVal)
   | opaque (_ : VDefVal)
   | example (_ : VDefVal)
   | quot
   | induct (_ : VInductDecl)
+  | mutualDef (_ : List VDefVal)
diff --git a/Lean4Lean/Theory/VEnv.lean b/Lean4Lean/Theory/VEnv.lean
index b0780ee9..a74d160b 100644
--- a/Lean4Lean/Theory/VEnv.lean
+++ b/Lean4Lean/Theory/VEnv.lean
@@ -12,13 +12,170 @@ structure VDefEq where
   rhs : VExpr
   type : VExpr
 
+/-- Syntax of one registered nonrecursive-structure eta rule.
+
+The projector family is fixed by the checked structure artifact.  Its three
+naturality fields are syntactic equations, not semantic assumptions; they
+are exactly what weakening and substitution need in order to reconstruct the
+same registered eta redex. -/
+structure VStructEta where
+  uvars : Nat
+  nparams : Nat
+  nfields : Nat
+  familyName : Name
+  familyType : VExpr
+  constructorName : Name
+  projectors : List VLevel → List VExpr → List VExpr
+  projectors_length : ∀ levels params,
+    levels.length = uvars → params.length = nparams →
+      (projectors levels params).length = nfields
+  projectors_liftN : ∀ levels params n k,
+    params.length = nparams →
+    (projectors levels params).map (fun projector =>
+      projector.liftN n k) =
+      projectors levels (params.map fun param => param.liftN n k)
+  projectors_instN : ∀ levels params a k,
+    params.length = nparams →
+    (projectors levels params).map (fun projector =>
+      projector.inst a k) =
+      projectors levels (params.map fun param => param.inst a k)
+  projectors_instL : ∀ levels params ls,
+    (projectors levels params).map (fun projector =>
+      projector.instL ls) =
+      projectors (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls))
+
+namespace VStructEta
+
+/-- The instantiated family type governed by a structure-eta descriptor. -/
+def structureType (rule : VStructEta) (levels : List VLevel)
+    (params : List VExpr) : VExpr :=
+  VExpr.appN (.const rule.familyName levels) params
+
+/-- Canonical projected fields of one major premise. -/
+def projectionArgs (rule : VStructEta) (levels : List VLevel)
+    (params : List VExpr) (major : VExpr) : List VExpr :=
+  (rule.projectors levels params).map fun projector => .app projector major
+
+/-- Constructor reconstruction contracted by the primitive eta rule. -/
+def rebuild (rule : VStructEta) (levels : List VLevel)
+    (params : List VExpr) (major : VExpr) : VExpr :=
+  VExpr.appN (.const rule.constructorName levels)
+    (params ++ rule.projectionArgs levels params major)
+
+@[simp] theorem structureType_liftN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (n k : Nat) :
+    (rule.structureType levels params).liftN n k =
+      rule.structureType levels
+        (params.map fun param => param.liftN n k) := by
+  unfold structureType
+  rw [VExpr.liftN_appN]
+  rfl
+
+@[simp] theorem structureType_instN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (a : VExpr) (k : Nat) :
+    (rule.structureType levels params).inst a k =
+      rule.structureType levels
+        (params.map fun param => param.inst a k) := by
+  unfold structureType
+  rw [VExpr.instN_appN]
+  rfl
+
+@[simp] theorem structureType_instL (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (ls : List VLevel) :
+    (rule.structureType levels params).instL ls =
+      rule.structureType (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) := by
+  unfold structureType
+  rw [VExpr.instL_appN]
+  rfl
+
+@[simp] theorem projectionArgs_length (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr)
+    (hlevels : levels.length = rule.uvars)
+    (hparams : params.length = rule.nparams) :
+    (rule.projectionArgs levels params major).length = rule.nfields := by
+  simp [projectionArgs,
+    rule.projectors_length levels params hlevels hparams]
+
+@[simp] theorem projectionArgs_liftN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr)
+    (hparams : params.length = rule.nparams) (n k : Nat) :
+    (rule.projectionArgs levels params major).map
+        (fun arg => arg.liftN n k) =
+      rule.projectionArgs levels
+        (params.map fun param => param.liftN n k) (major.liftN n k) := by
+  simpa [projectionArgs, VExpr.liftN, List.map_map, Function.comp_def] using
+    congrArg (List.map fun projector =>
+      projector.app (major.liftN n k))
+      (rule.projectors_liftN levels params n k hparams)
+
+@[simp] theorem projectionArgs_instN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major a : VExpr)
+    (hparams : params.length = rule.nparams) (k : Nat) :
+    (rule.projectionArgs levels params major).map
+        (fun arg => arg.inst a k) =
+      rule.projectionArgs levels
+        (params.map fun param => param.inst a k) (major.inst a k) := by
+  simpa [projectionArgs, VExpr.inst, List.map_map, Function.comp_def] using
+    congrArg (List.map fun projector => projector.app (major.inst a k))
+      (rule.projectors_instN levels params a k hparams)
+
+@[simp] theorem projectionArgs_instL (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr)
+    (ls : List VLevel) :
+    (rule.projectionArgs levels params major).map
+        (fun arg => arg.instL ls) =
+      rule.projectionArgs (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) (major.instL ls) := by
+  simpa [projectionArgs, VExpr.instL, List.map_map, Function.comp_def] using
+    congrArg (List.map fun projector => projector.app (major.instL ls))
+      (rule.projectors_instL levels params ls)
+
+@[simp] theorem rebuild_liftN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr)
+    (hparams : params.length = rule.nparams) (n k : Nat) :
+    (rule.rebuild levels params major).liftN n k =
+      rule.rebuild levels (params.map fun param => param.liftN n k)
+        (major.liftN n k) := by
+  unfold rebuild
+  rw [VExpr.liftN_appN, List.map_append,
+    rule.projectionArgs_liftN levels params major hparams n k]
+  rfl
+
+@[simp] theorem rebuild_instN (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major a : VExpr)
+    (hparams : params.length = rule.nparams) (k : Nat) :
+    (rule.rebuild levels params major).inst a k =
+      rule.rebuild levels (params.map fun param => param.inst a k)
+        (major.inst a k) := by
+  unfold rebuild
+  rw [VExpr.instN_appN, List.map_append,
+    rule.projectionArgs_instN levels params major a hparams k]
+  rfl
+
+@[simp] theorem rebuild_instL (rule : VStructEta)
+    (levels : List VLevel) (params : List VExpr) (major : VExpr)
+    (ls : List VLevel) :
+    (rule.rebuild levels params major).instL ls =
+      rule.rebuild (levels.map (VLevel.inst ls))
+        (params.map (VExpr.instL ls)) (major.instL ls) := by
+  unfold rebuild
+  rw [VExpr.instL_appN, List.map_append,
+    rule.projectionArgs_instL levels params major ls]
+  rfl
+
+end VStructEta
+
 @[ext] structure VEnv where
   constants : Name → Option VConstant
   defeqs : VDefEq → Prop
+  structEtas : VStructEta → Prop
 
 def VEnv.empty : VEnv where
   constants _ := none
   defeqs _ := False
+  structEtas _ := False
 
 instance : EmptyCollection VEnv := ⟨.empty⟩
 
@@ -32,13 +189,18 @@ def VEnv.addConst (env : VEnv) (name : Name) (ci : VConstant) : Option VEnv :=
 def VEnv.addDefEq (env : VEnv) (df : VDefEq) : VEnv :=
   { env with defeqs := fun x => x = df ∨ env.defeqs x }
 
+/-- Register one checked structure-eta descriptor. -/
+def VEnv.addStructEta (env : VEnv) (rule : VStructEta) : VEnv :=
+  { env with structEtas := fun x => x = rule ∨ env.structEtas x }
+
 structure VEnv.LE (env1 env2 : VEnv) : Prop where
   constants : env1.constants n = some a → env2.constants n = some a
   defeqs : env1.defeqs df → env2.defeqs df
+  structEtas : env1.structEtas rule → env2.structEtas rule
 
 instance : LE VEnv := ⟨VEnv.LE⟩
 
-theorem VEnv.LE.rfl {env : VEnv} : env ≤ env := ⟨id, id⟩
+theorem VEnv.LE.rfl {env : VEnv} : env ≤ env := ⟨id, id, id⟩
 
 theorem VEnv.LE.trans {a b c : VEnv} (h1 : a ≤ b) (h2 : b ≤ c) : a ≤ c :=
-  ⟨h2.1 ∘ h1.1, h2.2 ∘ h1.2⟩
+  ⟨h2.1 ∘ h1.1, h2.2 ∘ h1.2, h2.3 ∘ h1.3⟩
diff --git a/Lean4Lean/Theory/VExpr.lean b/Lean4Lean/Theory/VExpr.lean
index cdf8ed38..7abacc8c 100644
--- a/Lean4Lean/Theory/VExpr.lean
+++ b/Lean4Lean/Theory/VExpr.lean
@@ -34,6 +34,11 @@ theorem liftVar_lt_add (self : i < k) : liftVar n i j < k + n := by
 
 namespace VExpr
 
+/-- Iterated application, with arguments ordered from left to right. -/
+def appN (f : VExpr) : List VExpr → VExpr
+  | [] => f
+  | a :: as => (f.app a).appN as
+
 variable (n : Nat) in
 def liftN : VExpr → (k :_:= 0) → VExpr
   | .bvar i, k => .bvar (liftVar n i k)
@@ -245,6 +250,28 @@ def inst : VExpr → VExpr → (k :_:= 0) → VExpr
   | .lam ty body, e, k => .lam (ty.inst e k) (body.inst e (k+1))
   | .forallE ty body, e, k => .forallE (ty.inst e k) (body.inst e (k+1))
 
+theorem instL_appN (ls : List VLevel) (as : List VExpr) (f : VExpr) :
+    (appN f as).instL ls = appN (f.instL ls) (as.map (instL ls)) := by
+  induction as generalizing f with
+  | nil => rfl
+  | cons a as ih => simp [appN, instL, ih]
+
+theorem liftN_appN (n k : Nat) (f : VExpr) : ∀ (as : List VExpr),
+    (f.appN as).liftN n k = appN (f.liftN n k) (as.map (liftN n · k))
+  | [] => rfl
+  | a :: as => by
+    show (VExpr.appN (f.app a) as).liftN n k = _
+    rw [liftN_appN n k (f.app a) as]
+    rfl
+
+theorem instN_appN (a : VExpr) (k : Nat) (f : VExpr) : ∀ (as : List VExpr),
+    (f.appN as).inst a k = appN (f.inst a k) (as.map (·.inst a k))
+  | [] => rfl
+  | e :: as => by
+    show (VExpr.appN (f.app e) as).inst a k = _
+    rw [instN_appN a k (f.app e) as]
+    rfl
+
 @[simp] theorem inst_default : inst default e k = default := rfl
 
 theorem liftN_instN_lo (n : Nat) (e1 e2 : VExpr) (j k : Nat) (hj : k ≤ j) :
diff --git a/Lean4Lean/Theory/VLevel.lean b/Lean4Lean/Theory/VLevel.lean
index 7816d0f4..e0b36f24 100644
--- a/Lean4Lean/Theory/VLevel.lean
+++ b/Lean4Lean/Theory/VLevel.lean
@@ -35,7 +35,7 @@ def eval : VLevel → Nat
   | .zero => 0
   | .succ l => l.eval + 1
   | .max l₁ l₂ => l₁.eval.max l₂.eval
-  | .imax l₁ l₂ => l₁.eval.imax l₂.eval
+  | .imax l₁ l₂ => Lean.Nat.imax l₁.eval l₂.eval
   | .param i => ls.getD i 0
 
 protected def LE (a b : VLevel) : Prop := ∀ ls, a.eval ls ≤ b.eval ls
@@ -94,22 +94,22 @@ theorem LE.max_eq_right (h : a.LE b) : max a b ≈ b := by
 theorem max_self : max a a ≈ a := by simp [equiv_def, eval]
 
 theorem zero_imax : imax zero a ≈ a := by
-  simp [equiv_def, eval, Nat.imax, eq_comm (b := 0)]
+  simp [equiv_def, eval, Lean.Nat.imax, eq_comm (b := 0)]
 
-theorem imax_zero : imax a zero ≈ zero := by simp [equiv_def, eval, Nat.imax]
+theorem imax_zero : imax a zero ≈ zero := by simp [equiv_def, eval, Lean.Nat.imax]
 
 theorem imax_self : imax a a ≈ a := by
-  simp [equiv_def, eval, Nat.imax, eq_comm (b := 0)]
+  simp [equiv_def, eval, Lean.Nat.imax, eq_comm (b := 0)]
 
 theorem imax_eq_zero : imax a b ≈ zero ↔ b ≈ zero := by
-  simp [equiv_def, eval, Nat.imax]
+  simp [equiv_def, eval, Lean.Nat.imax]
   refine ⟨fun H ls => ?_, fun H ls hn => nomatch hn (H ls)⟩
   exact Decidable.byContradiction fun h => h (H ls h).2
 
 def IsNeverZero (a : VLevel) : Prop := ∀ ls, a.eval ls ≠ 0
 
 theorem IsNeverZero.imax_eq_max (h : IsNeverZero b) : imax a b ≈ max a b := by
-  simp_all [equiv_def, eval, Nat.imax, IsNeverZero]
+  simp_all [equiv_def, eval, Lean.Nat.imax, IsNeverZero]
 
 variable (ls : List VLevel) in
 def inst : VLevel → VLevel
diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean
index c71b1d61..70b28f54 100644
--- a/Lean4Lean/TypeChecker.lean
+++ b/Lean4Lean/TypeChecker.lean
@@ -63,7 +63,7 @@ instance (priority := low) : MonadWithReaderOf LocalContext M where
 
 structure Methods where
   protected isDefEqCore : Expr → Expr → M Bool
-  protected whnfCore (e : Expr) (cheapRec := false) (cheapProj := false) : M Expr
+  protected whnfCore (e : Expr) (cheapProj := false) : M Expr
   protected whnf (e : Expr) : M Expr
   protected inferType (e : Expr) (inferOnly : Bool) : M Expr
 
@@ -76,23 +76,29 @@ inductive ReductionStatus where
 
 namespace Inner
 
+/-- Reduces `e` to its weak-head normal form. -/
 def whnf (e : Expr) : RecM Expr := fun m => m.whnf e
 
 @[inline] def withLCtx [MonadWithReaderOf LocalContext m] (lctx : LocalContext) (x : m α) : m α :=
   withReader (fun _ => lctx) x
 
+/-- Ensures that `e` is defeq to some `e' := .sort ..`, returning `e'`. If not, throws an error with
+`s` (the expression required to be a sort). -/
 def ensureSortCore (e s : Expr) : RecM Expr := do
   if e.isSort then return e
   let e ← whnf e
   if e.isSort then return e
   throw <| .typeExpected (← getEnv) (← getLCtx) s
 
+/-- Ensures that `e` is defeq to some `e' := .forallE ..`, returning `e'`. If not, throws an error
+with `s := f a` (the application requiring `f` to be of function type). -/
 def ensureForallCore (e s : Expr) : RecM Expr := do
   if e.isForall then return e
   let e ← whnf e
   if e.isForall then return e
   throw <| .funExpected (← getEnv) (← getLCtx) s
 
+/-- Checks that `l` does not contain any level parameters not found in the context `tc`. -/
 def checkLevel (tc : Context) (l : Level) : Except Exception Unit := do
   if let some n2 := l.getUndefParam tc.lparams then
     throw <| .other s!"invalid reference to undefined universe level parameter '{n2}'"
@@ -102,6 +108,7 @@ def inferFVar (tc : Context) (name : FVarId) : Except Exception Expr := do
     return decl.type
   throw <| .other "unknown free variable"
 
+/-- Infers the type of `.const name ls`. -/
 def inferConstant (tc : Context) (name : Name) (ls : List Level) (inferOnly : Bool) :
     Except Exception Expr := do
   let e := Expr.const name ls
@@ -121,8 +128,14 @@ def inferConstant (tc : Context) (name : Name) (ls : List Level) (inferOnly : Bo
       checkLevel tc l
   return info.instantiateTypeLevelParams ls
 
+/-- Infers the type of expression `e`. If `inferOnly := false`, this function throws an error
+whenever `e` is not typeable according to Lean's algorithmic typing judgment (barring resource
+exhaustion: it may also throw `.deterministicTimeout` or `.deepRecursion` on a typeable term).
+Setting `inferOnly := true` optimizes to avoid unnecessary checks in the case that `e` is already
+known to be well-typed. -/
 def inferType (e : Expr) (inferOnly := true) : RecM Expr := fun m => m.inferType e inferOnly
 
+/-- Infers the type of lambda expression `e`. -/
 def inferLambda (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where
   loop fvars : Expr → RecM Expr
   | .lam name dom body bi => do
@@ -137,6 +150,7 @@ def inferLambda (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where
     let r := r.cheapBetaReduce
     return (← getLCtx).mkForall fvars r
 
+/-- Infers the type of for-all expression `e`. -/
 def inferForall (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] #[] e where
   loop fvars us : Expr → RecM Expr
   | .forallE name dom body bi => do
@@ -150,8 +164,17 @@ def inferForall (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] #[] e wher
     let s ← ensureSortCore r e
     return .sort <| us.foldr mkLevelIMax' s.sortLevel!
 
+/-- Returns whether `t` and `s` are definitionally equal according to Lean's algorithmic
+definitional equality judgment.
+
+NOTE: This function does not do any typechecking of its own on `t` and `s`. So, when this is used as
+part of a typechecking routine, it is expected that they are already well-typed (that is, that
+`checkType t` and `checkType s` did not/would not throw an error). This is what justifies the
+internal uses of `inferType` at its default `inferOnly := true`: on a well-typed subterm the fast
+path returns the same type the checking path would have. -/
 def isDefEqCore (t s : Expr) : RecM Bool := fun m => m.isDefEqCore t s
 
+@[inherit_doc isDefEqCore]
 def isDefEq (t s : Expr) : RecM Bool := do
   -- Syntactically equivalent expressions are definitionally equal without
   -- consulting or mutating the equivalence manager.  Besides avoiding
@@ -163,6 +186,7 @@ def isDefEq (t s : Expr) : RecM Bool := do
     modify fun st => { st with eqvManager := st.eqvManager.addEquiv t s }
   pure r
 
+/-- Infers the type of application `e`, assuming that `e` is already well-typed. -/
 def inferApp (e : Expr) : RecM Expr := do
   e.withApp fun f args =>
   let rec loop fType j i : RecM Expr :=
@@ -177,6 +201,7 @@ def inferApp (e : Expr) : RecM Expr := do
       return fType.instantiateRevRange j args.size args
   do loop (← inferType f) 0 0
 
+/-- Infers the type of let-expression `e`. -/
 def inferLet (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where
   loop fvars : Expr → RecM Expr
   | .letE name type val body _ => do
@@ -194,40 +219,61 @@ def inferLet (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where
     let r := r.cheapBetaReduce
     return (← getLCtx).mkForall fvars r
 
+/-- Gets the universe level of the sort that `e`'s type is defeq to, failing if `e` is not
+a type. -/
 def getSortLevel (e : Expr) : RecM Level := do
   let .sort u ← ensureSortCore (← inferType e) e | unreachable!
   return u
 
+/-- Checks if `e` is a proposition, that is, if its type is a sort whose level normalizes to
+zero. -/
 def isProp (e : Expr) : RecM Bool := return (← getSortLevel e).isAlwaysZero
 
+def invalidProj (e : Expr) : RecM α := do
+  throw <| .invalidProj (← getEnv) (← getLCtx) e
+
+def inferProjParams (proj : Expr) : List Expr → Expr → RecM Expr
+  | [], r => pure r
+  | arg :: args, r => do
+    let .forallE _ _ body _ ← whnf r | invalidProj proj
+    inferProjParams proj args (body.instantiate1 arg)
+
+def inferProjFields (proj : Expr) (typeName : Name)
+    (struct : Expr) (maybePropType : Bool) :
+    Nat → Nat → Expr → RecM Expr
+  | _, 0, r => pure r
+  | fieldIdx, count + 1, r => do
+    let .forallE _ dom body _ ← whnf r | invalidProj proj
+    if body.hasLooseBVars && maybePropType then
+      -- prop structs cannot have non-prop dependent fields
+      if !(← isProp dom) then invalidProj proj
+    inferProjFields proj typeName struct maybePropType (fieldIdx + 1) count
+      (body.instantiate1 (.proj typeName fieldIdx struct))
+
+/-- Infers the type of structure projection `e`. -/
 def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Expr := do
   let e := Expr.proj typeName idx struct
   let type ← whnf structType
   type.withApp fun I args => do
   let env ← getEnv
-  let fail {_} := do throw <| .invalidProj env (← getLCtx) e
-  let .const I_name I_levels := I | fail
-  if typeName != I_name then fail
-  let .inductInfo I_val ← env.get I_name | fail
-  let [c] := I_val.ctors | fail
-  if args.size != I_val.numParams + I_val.numIndices then fail
+  let .const I_name I_levels := I | invalidProj e
+  if typeName != I_name then invalidProj e
+  let .inductInfo I_val ← env.get I_name | invalidProj e
+  let [c] := I_val.ctors | invalidProj e
+  unless env.isProjectionReadyStructure I_name do invalidProj e
+  if args.size != I_val.numParams + I_val.numIndices then invalidProj e
   let c_info ← env.get c
-  let mut r := c_info.instantiateTypeLevelParams I_levels
-  for i in [:I_val.numParams] do
-    let .forallE _ _ b _ ← whnf r | fail
-    r := b.instantiate1 args[i]!
+  let .ctorInfo ctorInfo := c_info | invalidProj e
+  unless idx < ctorInfo.numFields do invalidProj e
+  let r ← inferProjParams e (args.toList.take I_val.numParams)
+    (c_info.instantiateTypeLevelParams I_levels)
   let maybePropType := !(← getSortLevel type).isNeverZero
-  for i in [:idx] do
-    let .forallE _ dom b _ ← whnf r | fail
-    if b.hasLooseBVars then
-      if maybePropType then if !(← isProp dom) then fail
-      r := b.instantiate1 (.proj I_name i struct)
-    else
-      r := b
-  let .forallE _ dom _ _ ← whnf r | fail
-  if maybePropType then if !(← isProp dom) then fail
+  let r ← inferProjFields e I_name struct maybePropType 0 idx r
+  let .forallE _ dom _ _ ← whnf r | invalidProj e
+  if maybePropType then if !(← isProp dom) then invalidProj e
   return dom
 
+@[inherit_doc inferType]
 def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do
   if e.hasLooseBVars then
     throw <| .other
@@ -262,6 +308,8 @@ def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do
         let fType ← ensureForallCore (← inferType' f inferOnly) e
         let aType ← inferType' a inferOnly
         let dType := fType.bindingDomain!
+        -- it can be shown that if `e` is typeable as `T`, then `T` is typeable as `Sort l`
+        -- for some universe level `l`, so this use of `isDefEq` is valid
         let ok ← if a.isAppOfArity ``eagerReduce 2 then
           withTheReader Context (fun s => {s with eagerReduce := true}) <|
             isDefEq dType aType
@@ -275,26 +323,40 @@ def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do
     { s with inferTypeC := s.inferTypeC.insert e r }
   return r
 
-def whnfCore (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr :=
-  fun m => m.whnfCore e cheapRec cheapProj
+/-- Reduces `e` to its weak-head normal form, without unfolding definitions. This is a conservative
+version of `whnf` (which does unfold definitions), to be used for efficiency purposes.
+
+Setting `cheapProj` to `true` will cause the struct argument to be reduced "lazily" (using
+`whnfCore` rather than `whnf`) when reducing struct projections, and suppresses caching of the
+result. This can be a useful optimization if we're checking the definitional equality of two struct
+projections of the same projection, where we might save some work by directly checking if the struct
+arguments are defeq (rather than eagerly applying a projection).
+
+The kernel has a companion `cheap_rec` flag doing the same for the major premise of a recursor, but
+nothing has set it since lean4#9275 removed the old compiler, so it is omitted here. -/
+def whnfCore (e : Expr) (cheapProj := false) : RecM Expr :=
+  fun m => m.whnfCore e cheapProj
 
-def reduceRecursor (e : Expr) (cheapRec := false) (cheapProj := false) : RecM (Option Expr) := do
+def reduceRecursor (e : Expr) : RecM (Option Expr) := do
   let env ← getEnv
   if env.quotInit then
     if let some r ← quotReduceRec e whnf then
       return r
-  let whnf' e := if cheapRec then whnfCore e cheapRec cheapProj else whnf e
-  if let some r ← inductiveReduceRec env e whnf' inferType isDefEq then
+  if let some r ← inductiveReduceRec env e whnf inferType isDefEq then
     return r
   return none
 
-def whnfFVar (e : Expr) (cheapRec cheapProj : Bool) : RecM Expr := do
+/-- Reduces the free variable `e`: to the `whnfCore` of its definition if `e` is a let variable,
+and to itself if it is a lambda variable. -/
+def whnfFVar (e : Expr) (cheapProj : Bool) : RecM Expr := do
   if let some (.ldecl (value := v) ..) := (← getLCtx).find? e.fvarId! then
-    return ← whnfCore v cheapRec cheapProj
+    return ← whnfCore v cheapProj
   return e
 
-def reduceProj (idx : Nat) (struct : Expr) (cheapRec cheapProj : Bool) : RecM (Option Expr) := do
-  let mut c ← (if cheapProj then whnfCore struct cheapRec cheapProj else whnf struct)
+/-- Reduces a projection of `struct` at index `idx` (when `struct` is reducible to a constructor
+application). -/
+def reduceProj (idx : Nat) (struct : Expr) (cheapProj : Bool) : RecM (Option Expr) := do
+  let mut c ← (if cheapProj then whnfCore struct cheapProj else whnf struct)
   if let .lit (.strVal s) := c then
     c ← whnf (.strLitToConstructor s)
   c.withApp fun mk args => do
@@ -306,52 +368,62 @@ def reduceProj (idx : Nat) (struct : Expr) (cheapRec cheapProj : Bool) : RecM (O
 def isLetFVar (lctx : LocalContext) (fvar : FVarId) : Bool :=
   lctx.find? fvar matches some (.ldecl ..)
 
-def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := do
+@[inherit_doc whnfCore]
+def whnfCore' (e : Expr) (cheapProj := false) : RecM Expr := do
   match e with
   | .bvar .. | .sort .. | .mvar .. | .forallE .. | .const .. | .lam .. | .lit .. => return e
-  | .mdata _ e => return ← whnfCore' e cheapRec cheapProj
+  | .mdata _ e => return ← whnfCore' e cheapProj
   | .fvar id => if !isLetFVar (← getLCtx) id then return e
   | .app .. | .letE .. | .proj .. => pure ()
   if let some r := (← get).whnfCoreCache[e]? then
     return r
   let rec save r := do
-    if !cheapRec && !cheapProj then
+    if !cheapProj then
       modify fun s => { s with whnfCoreCache := s.whnfCoreCache.insert e r }
     return r
   match e with
   | .bvar .. | .sort .. | .mvar .. | .forallE .. | .const .. | .lam .. | .lit ..
   | .mdata .. => unreachable!
-  | .fvar _ => return ← whnfFVar e cheapRec cheapProj
+  | .fvar _ => return ← whnfFVar e cheapProj
   | .app .. =>
+    -- beta-reduce at the head as much as possible, apply any remaining `rargs`
+    -- to the resulting expression, and re-run `whnfCore`
     e.withAppRev fun f0 rargs => do
-    let f ← whnfCore f0 cheapRec cheapProj
+    -- the head may still be a let variable/binding, projection, or mdata-wrapped expression
+    let f ← whnfCore f0 cheapProj
     if let .lam _ _ body _ := f then
       let rec loop m (f : Expr) : RecM Expr :=
         let rec cont := do
           let r := f.instantiateRange (rargs.size - m) rargs.size rargs
           let r := r.mkAppRevRange 0 (rargs.size - m) rargs
-          save <|← whnfCore r cheapRec cheapProj
+          save <|← whnfCore r cheapProj
         if let .lam _ _ body _ := f then
           if m < rargs.size then loop (m + 1) body
           else cont
         else cont
       loop 1 body
     else if Expr.structuralEq f f0 then
-      if let some r ← reduceRecursor e cheapRec cheapProj then
-        whnfCore r cheapRec cheapProj
+      if let some r ← reduceRecursor e then
+        whnfCore r cheapProj
       else
         pure e
     else
       let r := f.mkAppRevRange 0 rargs.size rargs
-      save <|← whnfCore r cheapRec cheapProj
+      -- the recursive call re-decomposes `r` and reaches the `f == f0` branch above, so
+      -- `reduceRecursor` is still applied; adding arguments can only enable further normalization
+      -- if the head reduced to a partial recursor application
+      save <|← whnfCore r cheapProj
   | .letE _ _ val body _ =>
-    save <|← whnfCore (body.instantiate1 val) cheapRec cheapProj
+    save <|← whnfCore (body.instantiate1 val) cheapProj
   | .proj _ idx s =>
-    if let some m ← reduceProj idx s cheapRec cheapProj then
-      save <|← whnfCore m cheapRec cheapProj
+    if let some m ← reduceProj idx s cheapProj then
+      save <|← whnfCore m cheapProj
     else
       save e
 
+/-- Checks if the head of `e` is a constant that can be delta-reduced, applied to the right number
+of universe levels, returning its `ConstantInfo` if so. See `ConstantInfo.deltaValue?` for which
+constants qualify. -/
 def isDelta (env : Environment) (e : Expr) : Option ConstantInfo := do
   if let .const c ls := e.getAppFn then
     if let some ci := env.find? c then
@@ -362,6 +434,9 @@ def isDelta (env : Environment) (e : Expr) : Option ConstantInfo := do
 def instantiateDeltaValue (ci : ConstantInfo) (ls : List Level) : Expr :=
   ci.deltaValue?.get!.instantiateLevelParams ci.levelParams ls
 
+/-- If `e` is itself a constant that can be delta-reduced, returns its value with the constant's
+level parameters instantiated. Unlike `unfoldDefinition`, this does not look through applications:
+`e` must be a `.const`. -/
 def unfoldDefinitionCore (e : Expr) : RecM (Option Expr) := do
   let .const _ ls := e | return none
   let env ← getEnv
@@ -372,6 +447,8 @@ def unfoldDefinitionCore (e : Expr) : RecM (Option Expr) := do
   modify fun s => { s with unfold := s.unfold.insert e r }
   return some r
 
+/-- Unfolds the definition at the head of the application `e` (or `e` itself if it is not an
+application). -/
 def unfoldDefinition (e : Expr) : RecM (Option Expr) := do
   if e.isApp then
     let f0 := e.getAppFn
@@ -391,6 +468,9 @@ def reduceNative (_env : Environment) (e : Expr) : Except Exception (Option Expr
 
 def rawNatLitExt? (e : Expr) : Option Nat := if e == .natZero then some 0 else e.rawNatLit?
 
+/-- Reduces the application `f a b` to a Nat literal if `a` and `b` can be reduced to Nat literals.
+
+Note: `f` should have an (efficient) external implementation. -/
 def reduceBinNatOp (f : Nat → Nat → Nat) (a b : Expr) : RecM (Option Expr) := do
   let some v1 := rawNatLitExt? (← whnf a) | return none
   let some v2 := rawNatLitExt? (← whnf b) | return none
@@ -404,11 +484,20 @@ def reducePow (a b : Expr) : RecM (Option Expr) := do
   if v2 > reducePowMaxExp then return none
   return some <| .lit <| .natVal <| Nat.pow v1 v2
 
+/-- Reduces the application `f a b` to a boolean expression if `a` and `b` can be reduced to Nat
+literals.
+
+Note: `f` should have an (efficient) external implementation. -/
 def reduceBinNatPred (f : Nat → Nat → Bool) (a b : Expr) : RecM (Option Expr) := do
   let some v1 := rawNatLitExt? (← whnf a) | return none
   let some v2 := rawNatLitExt? (← whnf b) | return none
   return toExpr <| f v1 v2
 
+/-- Reduces `e` to a literal if possible, where the unary operation `Nat.succ` and the binary
+operations and predicates with an external implementation may be applied: `Nat.add`, `Nat.sub`,
+`Nat.mul`, `Nat.pow`, `Nat.gcd`, `Nat.mod`, `Nat.div`, `Nat.land`, `Nat.lor`, `Nat.xor`,
+`Nat.shiftLeft`, `Nat.shiftRight` produce a `Nat` literal, while the predicates `Nat.beq` and
+`Nat.ble` produce a `Bool` literal. -/
 def reduceNat (e : Expr) : RecM (Option Expr) := do
   let nargs := e.getAppNumArgs
   if nargs == 1 then
@@ -434,6 +523,7 @@ def reduceNat (e : Expr) : RecM (Option Expr) := do
     if f == ``Nat.shiftRight then return ← reduceBinNatOp Nat.shiftRight a b
   return none
 
+@[inherit_doc whnf]
 def whnf' (e : Expr) : RecM Expr := do
   -- Do not cache easy cases
   match e with
@@ -460,6 +550,9 @@ def whnf' (e : Expr) : RecM Expr := do
   modify fun s => { s with whnfCache := s.whnfCache.insert e r }
   return r
 
+/-- If `t` and `s` are lambda expressions, checks that their domains are defeq and recurses on the
+bodies, substituting in a new free variable for that binder (this substitution is delayed for
+efficiency purposes using the `subst` parameter). Otherwise, does a normal defeq check. -/
 def isDefEqLambda (t s : Expr) (subst : Array Expr := #[]) : RecM Bool :=
   match t, s with
   | .lam _ tDom tBody _, .lam name sDom sBody bi => do
@@ -476,6 +569,9 @@ def isDefEqLambda (t s : Expr) (subst : Array Expr := #[]) : RecM Bool :=
       isDefEqLambda tBody sBody (subst.push default)
   | t, s => isDefEq (t.instantiateRev subst) (s.instantiateRev subst)
 
+/-- If `t` and `s` are for-all expressions, checks that their domains are defeq and recurses on the
+bodies, substituting in a new free variable for that binder (this substitution is delayed for
+efficiency purposes using the `subst` parameter). Otherwise, does a normal defeq check. -/
 def isDefEqForall (t s : Expr) (subst : Array Expr := #[]) : RecM Bool :=
   match t, s with
   | .forallE _ tDom tBody _, .forallE name sDom sBody bi => do
@@ -492,7 +588,16 @@ def isDefEqForall (t s : Expr) (subst : Array Expr := #[]) : RecM Bool :=
       isDefEqForall tBody sBody (subst.push default)
   | t, s => isDefEq (t.instantiateRev subst) (s.instantiateRev subst)
 
+/-- Decides definitional equality of `t` and `s` in the cases that can be settled without
+reduction, returning `.undef` to defer to the calling function otherwise.
+
+It returns `.true` if they are α-equivalent or have previously been checked for definitional
+equality, and otherwise decides two sorts by level equivalence and two literals by equality,
+returning `.false` where these disagree. Two lambdas or two for-alls are handed to
+`isDefEqLambda`/`isDefEqForall`, which may return either. All remaining cases — including two
+constants, two free variables, two applications and two projections — are deferred. -/
 def quickIsDefEq (t s : Expr) (useHash := false) : RecM LBool := do
+  -- optimization for terms that are already α-equivalent or were previously checked
   if ← modifyGet fun (.mk a1 a2 a3 a4 a5 a6 a7 (eqvManager := m)) =>
     let (b, m) := m.isEquiv useHash t s
     (b, .mk a1 a2 a3 a4 a5 a6 a7 (eqvManager := m))
@@ -506,6 +611,9 @@ def quickIsDefEq (t s : Expr) (useHash := false) : RecM LBool := do
   | .lit a1, .lit a2 => pure (a1 == a2).toLBool
   | _, _ => return .undef
 
+/-- Assuming that `t` and `s` have the same function heads, returns true if they are applications
+with definitionally equal arguments (in which case they are defeq), and false otherwise (deferring
+further defeq checking to caller). -/
 def isDefEqArgs (t s : Expr) : RecM Bool := do
   match t, s with
   | .app tf ta, .app sf sa =>
@@ -514,15 +622,40 @@ def isDefEqArgs (t s : Expr) : RecM Bool := do
   | .app .., _ | _, .app .. => return false
   | _, _ => return true
 
+/-- Assuming `t` and `s` are WHNF, checks if they are defeq on account of `t` being an η-expansion
+of `s`.
+
+Assuming that `s` has a function type `(x : A) → B x`, it η-expands to `fun (x : A) => s x`
+(which it is definitionally equal to by the η rule). -/
 def tryEtaExpansionCore (t s : Expr) : RecM Bool := do
   if t.isLambda && !s.isLambda then
     let .forallE name ty _ bi ← whnf (← inferType s) | return false
     isDefEq t (.lam name ty (.app s (.bvar 0)) bi)
   else return false
 
+@[inherit_doc tryEtaExpansionCore]
 def tryEtaExpansion (t s : Expr) : RecM Bool :=
   tryEtaExpansionCore t s <||> tryEtaExpansionCore s t
 
+/-- One field comparison in the structure-eta fast path.  Naming the
+callback keeps the executable range loop and its verification aligned without
+depending on proof terms synthesized by `for` notation. -/
+def tryEtaStructFieldStep (t : Expr) (induct : Name) (numParams : Nat)
+    (args : Array Expr) (i : Nat) (_ : i ∈ [numParams:args.size])
+    (_ : Option Bool × PUnit) :
+    RecM (ForInStep (Option Bool × PUnit)) := do
+  let b ← isDefEq (.proj induct (i - numParams) t) args[i]
+  if b = true then
+    pure (.yield ⟨none, PUnit.unit⟩)
+  else
+    pure (.done ⟨some false, PUnit.unit⟩)
+
+/-- Assuming `t` and `s` in WHNF, checks if they are defeq on account of `s` being defeq to the
+struct-η-expansion of `t`.
+
+Assuming that `t` has a non-recursive structure type `S` with constructor `S.mk` and projections
+`pᵢ`, it struct-η-expands to `S.mk (p₁ t) ... (pₙ t)` (which it is definitionally equal to by the
+struct-η rule). -/
 def tryEtaStructCore (t s : Expr) : RecM Bool := do
   let .const f _ := s.getAppFn | return false
   let env ← getEnv
@@ -531,13 +664,23 @@ def tryEtaStructCore (t s : Expr) : RecM Bool := do
   unless env.isNonRecStructure fInfo.induct do return false
   unless ← isDefEq (← inferType t) (← inferType s) do return false
   let args := s.getAppArgs
-  for h : i in [fInfo.numParams:args.size] do
-    unless ← isDefEq (.proj fInfo.induct (i - fInfo.numParams) t) args[i] do return false
-  return true
-
+  -- since `t` is in WHNF, and assuming it is not a constructor application, this projection
+  -- cannot reduce (so we are directly checking if `s` is defeq to the struct-η-expansion of `t`)
+  let r ← forIn' [fInfo.numParams:args.size] ⟨none, PUnit.unit⟩
+    (tryEtaStructFieldStep t fInfo.induct fInfo.numParams args)
+  match r.1 with
+  | none => return true
+  | some b => return b
+
+@[inherit_doc tryEtaStructCore]
 def tryEtaStruct (t s : Expr) : RecM Bool :=
+  -- when `t` and `s` are both constructor applications, `isDefEqApp` has already compared their
+  -- arguments and returned false, and the projections in `tryEtaStructCore` reduce back to those
+  -- same arguments, so both calls below merely redo that work. The kernel has the same redundancy.
   tryEtaStructCore t s <||> tryEtaStructCore s t
 
+/-- Checks if applications `t` and `s` (should be WHNF) are defeq on account of their function heads
+and arguments being defeq. -/
 def isDefEqApp (t s : Expr) : RecM Bool := do
   unless t.isApp && s.isApp do return false
   t.withApp fun tf tArgs =>
@@ -552,6 +695,8 @@ def isDefEqApp (t s : Expr) : RecM Bool := do
     loop 0
   else return false
 
+/-- Checks if `t` and `s` are definitionally equivalent according to proof irrelevance (that is,
+they are proofs of the same proposition). -/
 def isDefEqProofIrrel (t s : Expr) : RecM LBool := do
   let tType ← inferType t
   if !(← isProp tType) then return .undef
@@ -575,6 +720,15 @@ def tryUnfoldProjApp (e : Expr) : RecM (Option Expr) := do
   let e' ← whnfCore e
   return if e' != e then e' else none
 
+/-- Performs a single step of δ-reduction on `tn`, `sn`, or both (according to optimizations)
+followed by weak-head normalization (without further δ-reduction). Returns `.bool` if the resulting
+terms are settled by `quickIsDefEq`, or if they are applications of the same defined constant with
+defeq args. Otherwise returns `.continue`, indicating to the calling `lazyDeltaReduction` that
+δ-reduction is to be continued.
+
+If neither side has a δ-reducible head, returns `.unknown` with the terms unchanged, leaving further
+defeq-checking to `isDefEqCore'`. Note that these are weak-head normal forms with respect to
+`cheapProj := true`, so a projection at the head may still be reducible. -/
 def lazyDeltaReductionStep (tn sn : Expr) : RecM ReductionStatus := do
   let env ← getEnv
   let delta e := do whnfCore (← unfoldDefinition e).get! (cheapProj := true)
@@ -586,6 +740,8 @@ def lazyDeltaReductionStep (tn sn : Expr) : RecM ReductionStatus := do
   match isDelta env tn, isDelta env sn with
   | none, none => return .unknown tn sn
   | some _, none =>
+    -- `sn` was normalized with `cheapProj := true`, so a projection at its head may not have been
+    -- reduced; `tryUnfoldProjApp` retries it with the struct argument fully normalized
     if let some sn' ← tryUnfoldProjApp sn then
       cont tn sn'
     else
@@ -620,6 +776,9 @@ def isNatSuccOf? : Expr → Option Expr
   | .app (.const ``Nat.succ _) e => return e
   | _ => none
 
+/-- Returns `.true` if `t` and `s` are both zero, either as a literal or as `Nat.zero`. If they are
+both successors of natural numbers `t'` and `s'`, either as literals or `Nat.succ` applications,
+checks that `t'` and `s'` are definitionally equal. Otherwise, defers to the calling function. -/
 def isDefEqOffset (t s : Expr) : RecM LBool := do
   if isNatZero t && isNatZero s then
     return .true
@@ -627,6 +786,14 @@ def isDefEqOffset (t s : Expr) : RecM LBool := do
   | some t', some s' => toLBoolM <| isDefEqCore t' s'
   | _, _ => return .undef
 
+/-- Repeatedly δ-reduces the `cheapProj := true` weak-head normal forms `tn` and `sn` until the
+question is settled. Returns `.bool` if:
+- they are both zero or both natural number successors (as literals or `Nat.succ` applications)
+- one of them can be converted to a natural number/boolean literal
+- a `lazyDeltaReductionStep` settles them
+
+Otherwise returns `.unknown` with the reduced terms, deferring to the calling function. Throws
+`.deterministicTimeout` after `FuelConfig.lazyDelta` steps. -/
 def lazyDeltaReduction (tn sn : Expr) : RecM ReductionStatus := do
   loop tn sn (← readThe Context).fuel.lazyDelta
 where
@@ -649,17 +816,23 @@ where
     | .continue tn sn => loop tn sn fuel
     | r => return r
 
+/-- If `t` is a string literal and `s` is a `String.ofList` application, checks that they are defeq
+after expanding `t` into a `String.ofList` application of an explicit character list. Otherwise,
+defers to the calling function. -/
 def tryStringLitExpansionCore (t s : Expr) : RecM LBool := do
   let .lit (.strVal st) := t | return .undef
   let .app sf _ := s | return .undef
   unless sf == .const ``String.ofList [] do return .undef
   toLBoolM <| isDefEqCore (.strLitToConstructor st) s
 
+@[inherit_doc tryStringLitExpansionCore]
 def tryStringLitExpansion (t s : Expr) : RecM LBool := do
   match ← tryStringLitExpansionCore t s with
   | .undef => tryStringLitExpansionCore s t
   | r => return r
 
+/-- Checks if `t` and `s` are defeq on account of both being of a unit type (a type with one
+constructor without any fields or indices). -/
 def isDefEqUnitLike (t s : Expr) : RecM Bool := do
   let tType ← whnf (← inferType t)
   let .const I _ := tType.getAppFn | return false
@@ -669,6 +842,7 @@ def isDefEqUnitLike (t s : Expr) : RecM Bool := do
   let .ctorInfo { numFields := 0, .. } ← env.get c | return false
   isDefEqCore tType (← inferType s)
 
+@[inherit_doc isDefEqCore]
 def isDefEqCore' (t s : Expr) : RecM Bool := do
   let r ← quickIsDefEq t s (useHash := true)
   if r != .undef then return r == .true
@@ -696,14 +870,18 @@ def isDefEqCore' (t s : Expr) : RecM Bool := do
     if tf == sf && Level.isEquivList tl sl then return true
   | .fvar tv, .fvar sv => if tv == sv then return true
   | .proj _ ti te, .proj _ si se =>
+    -- optimized by the previous reduction functions using `cheapProj := true`
     if ti == si then if ← isDefEq te se then return true
   | _, _ => pure ()
 
+  -- the previous reduction functions used `cheapProj := true`, so we may not have a complete WHNF
   let tnn ← whnfCore tn
   let snn ← whnfCore sn
   if !(ptrEqExpr tnn tn && ptrEqExpr snn sn) then
+    -- if projection reduced, need to re-run (as we may not have a WHNF)
     return ← isDefEqCore tnn snn
 
+  -- tn and sn are both in WHNF
   if ← isDefEqApp tn sn then return true
   if ← tryEtaExpansion tn sn then return true
   if ← tryEtaStruct tn sn then return true
@@ -719,15 +897,16 @@ open Inner
 def Methods.withFuel : Nat → Methods
   | 0 =>
     { isDefEqCore := fun _ _ => throw .deepRecursion
-      whnfCore := fun _ _ _ => throw .deepRecursion
+      whnfCore := fun _ _ => throw .deepRecursion
       whnf := fun _ => throw .deepRecursion
       inferType := fun _ _ => throw .deepRecursion }
   | n + 1 =>
     { isDefEqCore := fun t s => isDefEqCore' t s (withFuel n)
-      whnfCore := fun e r p => whnfCore' e r p (withFuel n)
+      whnfCore := fun e p => whnfCore' e p (withFuel n)
       whnf := fun e => whnf' e (withFuel n)
       inferType := fun e i => inferType' e i (withFuel n) }
 
+/-- Runs `x` with a limit on the recursion depth, taken from `FuelConfig.recDepth`. -/
 def RecM.run (x : RecM α) : M α := do x (Methods.withFuel (← readThe Context).fuel.recDepth)
 
 def RecM.runTermElab (x : RecM α) (safety := DefinitionSafety.safe) : Elab.Term.TermElabM α :=
@@ -735,24 +914,37 @@ def RecM.runTermElab (x : RecM α) (safety := DefinitionSafety.safe) : Elab.Term
 
 instance : MonadLift RecM Elab.Term.TermElabM := ⟨RecM.runTermElab⟩
 
+@[inherit_doc whnf']
 def whnf (e : Expr) : M Expr := (Inner.whnf e).run
 
 def whnfCore (e : Expr) : M Expr := (Inner.whnfCore e).run
 
 def unfoldDefinition (e : Expr) : M Expr := return (← (Inner.unfoldDefinition e).run).getD e
 
+/-- Infers the type of expression `e`. Note that this uses the optimization `inferOnly := true`, and
+so should only be used for the purpose of type inference on terms that are known to be well-typed.
+To typecheck terms for the first time, use `checkType`. -/
 def inferType (e : Expr) : M Expr := (Inner.inferType e).run
 
+/-- Infers the type of expression `e` and checks that `e` is well-typed according to Lean's typing
+judgment.
+
+Use `inferType` to infer type alone. -/
 def checkType (e : Expr) : M Expr := (Inner.inferType e (inferOnly := false)).run
 
+@[inherit_doc isDefEqCore]
 def isDefEq (t s : Expr) : M Bool := (Inner.isDefEq t s).run
 
+@[inherit_doc Inner.isProp]
 def isProp (t : Expr) : M Bool := (Inner.isProp t).run
 
+@[inherit_doc ensureSortCore]
 def ensureSort (t : Expr) (s := t) : M Expr := (ensureSortCore t s).run
 
+@[inherit_doc ensureForallCore]
 def ensureForall (t : Expr) (s := t) : M Expr := (ensureForallCore t s).run
 
+/-- Ensures that `e` is a type/proposition. If it is not, throws an error. -/
 def ensureType (e : Expr) : M Expr := do ensureSort (← inferType e) e
 
 def etaExpand (e : Expr) : M Expr :=
diff --git a/Lean4Lean/Verify.lean b/Lean4Lean/Verify.lean
index d9faa29f..6e4c10cd 100644
--- a/Lean4Lean/Verify.lean
+++ b/Lean4Lean/Verify.lean
@@ -1 +1,3 @@
 import Lean4Lean.Verify.Typing.Lemmas
+import Lean4Lean.Verify.Environment
+import Lean4Lean.Verify.Environment.InductiveReplayMatrix
diff --git a/Lean4Lean/Verify/Axioms.lean b/Lean4Lean/Verify/Axioms.lean
index c145291d..f620c116 100644
--- a/Lean4Lean/Verify/Axioms.lean
+++ b/Lean4Lean/Verify/Axioms.lean
@@ -10,6 +10,10 @@ variable {α : Type u} {β : Type v} {cmp : α → α → Ordering} {t : TreeMap
 axiom all_eq_all_toList {p : α → β → Bool} :
     t.all p = t.toList.all fun a => p a.1 a.2
 
+/-- https://github.com/leanprover/lean4/issues/12798 -/
+axiom any_eq_any_toList {p : α → β → Bool} :
+    t.any p = t.toList.any fun a => p a.1 a.2
+
 end Std.TreeMap
 
 open scoped _root_.List
@@ -113,6 +117,145 @@ end Syntax
 
 namespace Level
 
+/-!
+### A total copy of `Lean.Level.normalize`
+
+`Lean.Level.normalize` and four of its helpers are `partial def`s, so they are opaque and nothing
+can be proved about them. The `Total` namespace below is a clause-by-clause copy of
+[Lean's `Lean/Level.lean`](https://github.com/leanprover/lean4/blob/v4.33.0-rc2/src/Lean/Level.lean#L319-L404),
+under the same names, with the termination proofs supplied. That makes `normalize_eq` below a
+purely syntactic trust assumption, checkable by reading the two definitions side by side;
+`Lean4Lean.Tests.LevelStd` also checks it on a finite corpus of levels.
+-/
+namespace Total
+
+/-- The structural size of a level, used as the termination measure for `normalize`. -/
+def size : Level → Nat
+  | .zero | .param _ | .mvar _ => 1
+  | .succ l => size l + 1
+  | .max l₁ l₂ => size l₁ + size l₂ + 1
+  | .imax l₁ l₂ => size l₁ + size l₂ + 2
+
+/-- Secondary termination measure for `normalize`: in the `imax` branch it recurses on
+`mkLevelMax l₁ l₂`, which has the same `size` as `imax l₁ l₂` but a smaller `tag`. -/
+private def tag (l : Level) : Nat :=
+  match l.getLevelOffset with
+  | .imax .. => 1
+  | _ => 0
+
+private theorem tag_le (l : Level) : tag l ≤ 1 := by unfold tag; split <;> omega
+
+theorem one_le_size (l : Level) : 1 ≤ size l := by cases l <;> simp [size]
+
+private theorem getOffsetAux_eq (l : Level) (k) : getOffsetAux l k = getOffsetAux l 0 + k := by
+  induction l generalizing k with
+  | succ l ih => rw [getOffsetAux, ih (k+1), getOffsetAux, ih 1]; omega
+  | _ => simp [getOffsetAux]
+
+theorem size_getLevelOffset (l : Level) :
+    size l.getLevelOffset + l.getOffset = size l := by
+  simp only [getOffset]
+  induction l with | succ l ih => ?_ | _ => rfl
+  show size l.getLevelOffset + getOffsetAux l 1 = size l + 1
+  rw [getOffsetAux_eq l 1]; omega
+
+end Total
+open private accMax mkIMaxAux mkMaxAux skipExplicit isExplicitSubsumedAux
+  isExplicitSubsumed from Lean.Level
+
+def Total.mkMaxAux (lvls : Array Level) (extraK : Nat) (i : Nat)
+    (prev : Level) (prevK : Nat) (result : Level) : Level :=
+  if h : i < lvls.size then
+    let lvl   := lvls[i]
+    let curr  := lvl.getLevelOffset
+    let currK := lvl.getOffset
+    if curr == prev then mkMaxAux lvls extraK (i+1) curr currK result
+    else mkMaxAux lvls extraK (i+1) curr currK (accMax result prev (extraK + prevK))
+  else accMax result prev (extraK + prevK)
+
+/-- Patch for `partial def Lean.Level.mkMaxAux`. -/
+@[simp] axiom mkMaxAux_eq : mkMaxAux = Total.mkMaxAux
+
+def Total.skipExplicit (lvls : Array Level) (i : Nat) : Nat :=
+  if h : i < lvls.size then
+    if lvls[i].getLevelOffset.isZero then skipExplicit lvls (i+1) else i
+  else i
+
+/-- Patch for `partial def Lean.Level.skipExplicit`. -/
+@[simp] axiom skipExplicit_eq : skipExplicit = Total.skipExplicit
+
+def Total.isExplicitSubsumedAux (lvls : Array Level) (maxExplicit : Nat) (i : Nat) : Bool :=
+  if h : i < lvls.size then
+    if lvls[i].getOffset ≥ maxExplicit then true
+    else isExplicitSubsumedAux lvls maxExplicit (i+1)
+  else false
+
+/-- Patch for `partial def Lean.Level.isExplicitSubsumedAux`. -/
+@[simp] axiom isExplicitSubsumedAux_eq : isExplicitSubsumedAux = Total.isExplicitSubsumedAux
+
+mutual
+
+/-- A total copy of `partial def Lean.Level.normalize`. -/
+def Total.normalize (l : Level) : Level :=
+  if isAlreadyNormalizedCheap l then l else
+  let k := l.getOffset
+  match h : l.getLevelOffset with
+  | .max l₁ l₂ =>
+    let lvls  := getMaxArgsAux l₁ false #[]
+    let lvls  := getMaxArgsAux l₂ false lvls
+    let lvls  := lvls.qsort normLt
+    let firstNonExplicit := skipExplicit lvls 0
+    let i := if isExplicitSubsumed lvls firstNonExplicit then firstNonExplicit
+              else firstNonExplicit - 1
+    let lvl₁  := lvls[i]!
+    let prev  := lvl₁.getLevelOffset
+    let prevK := lvl₁.getOffset
+    mkMaxAux lvls k (i+1) prev prevK Level.zero
+  | .imax l₁ l₂ =>
+    if l₂.isNeverZero then addOffset (normalize (mkLevelMax l₁ l₂)) k
+    else addOffset (mkIMaxAux (normalize l₁) (normalize l₂)) k
+  | _ => unreachable!
+termination_by (1, 3 * size l + tag l)
+decreasing_by all_goals
+  refine .right _ ?_
+  have hsz := size_getLevelOffset l
+  rw [h] at hsz
+  simp only [size] at hsz
+  have := one_le_size l₁
+  have := one_le_size l₂
+  have := tag_le l₁
+  have := tag_le l₂
+  first
+  | omega
+  | have ht : tag l = 1 := by simp [tag, h]
+    have e1 : size (mkLevelMax l₁ l₂) = size l₁ + size l₂ + 1 := rfl
+    have e2 : tag (mkLevelMax l₁ l₂) = 0 := rfl
+    omega
+
+def Total.getMaxArgsAux : Level → Bool → Array Level → Array Level
+  | .max l₁ l₂, norm, lvls => getMaxArgsAux l₂ norm (getMaxArgsAux l₁ norm lvls)
+  | l, false, lvls => getMaxArgsAux (normalize l) true lvls
+  | l, true, lvls => lvls.push l
+termination_by l b => (if b then 0 else 1, 3 * size l + tag l + 1)
+decreasing_by
+  any_goals cases norm
+  any_goals first | refine .right _ ?_ | exact .left _ _ (by decide)
+  all_goals first
+  | omega
+  | have e1 : size (Level.max l₁ l₂) = size l₁ + size l₂ + 1 := rfl
+    have e2 : tag (Level.max l₁ l₂) = 0 := rfl
+    have := one_le_size l₁
+    have := one_le_size l₂
+    have := tag_le l₁
+    have := tag_le l₂
+    omega
+
+end
+
+/-- `Lean.Level.normalize` is a `partial def`, so it is opaque;
+`Total.normalize` above is a total copy of it. -/
+axiom normalize_eq : normalize = Total.normalize
+
 def mkData' (h : UInt64) (depth : Nat := 0) (hasMVar hasParam : Bool := false) : Level.Data :=
   if depth > Nat.pow 2 24 - 1 then panic! "universe level depth is too big"
   else
diff --git a/Lean4Lean/Verify/Environment.lean b/Lean4Lean/Verify/Environment.lean
index 1e85a11c..85ec879c 100644
--- a/Lean4Lean/Verify/Environment.lean
+++ b/Lean4Lean/Verify/Environment.lean
@@ -1,20 +1,222 @@
-import Lean4Lean.Verify.TypeChecker
-import Lean4Lean.Environment
+import Lean4Lean.Verify.Environment.Extension
 
 namespace Lean4Lean
-
+open Lean4Lean
 open Lean hiding Environment Exception
 open Kernel
 
-/-- The intended main theorem of the `Verify` development, currently unproved:
-if `env` is well-formed and `addDecl env decl` (in checking mode) succeeds,
-then the resulting environment is also well-formed, and it extends `env`.
+open private Lean.Kernel.Environment.add from Lean.Environment
 
-None of the pieces of this theorem exist yet: nothing relates
-`Lean.Kernel.Environment.add` to the `TrEnv` relation, and nothing repackages
-the `checkType.WF`/`isDefEq.WF` postconditions at the empty local context into
-the abstract `VDecl.WF` premises needed to extend `TrEnv`. -/
-theorem addDecl.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (decl : Declaration) :
-    (addDecl env decl).WF fun env' =>
-      ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety :=
+theorem addAxiom.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : AxiomVal) :
+    (addAxiom env v).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety,
+        (ves.venv safety).AddConst safety (.axiomInfo v) ci'.toVConstant (ves'.venv safety) := by
+  let checkSafety : DefinitionSafety := if v.isUnsafe then .unsafe else .safe
+  have hsafety : checkSafety ≤ (ConstantInfo.axiomInfo v).safety := by
+    cases v.isUnsafe <;> exact DefinitionSafety.le_rfl
+  unfold addAxiom
+  refine (checkConstantVal.WF wf (.axiomInfo v) false hsafety).run wf |>.bind fun _ h => ?_
+  obtain ⟨ci', htr, hci, hn, hnonprim⟩ := h
+  have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.axiomInfo v) ci' checkSafety ?_ htr hci hn
+    (hnonprim rfl) fun _ _ htr hci hadd old => ?_
+  · exact .pure ⟨ves', hwf, ci', hstep⟩
+  · intro safety _
+    cases v.isUnsafe <;> cases safety <;> trivial
+  · exact .axiom htr (by rwa [← old.map_wf.find?'_eq_find?]) hci hadd old
+
+theorem addDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : DefinitionVal) :
+    (addDefinition env v).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ (∀ safety, ves.venv safety ≤ ves'.venv safety) ∧
+        (v.safety ≠ .unsafe → ∃ ci' : VDefVal, ∀ safety,
+          (ves.venv safety).AddDef safety (.defnInfo v) ci' (ves'.venv safety)) := by
+  unfold addDefinition; split
+  · refine checkConstantVal.WF wf (.defnInfo v) false DefinitionSafety.unsafe_le
+      |>.run wf |>.bind fun _ ⟨ci0, htr, hwfc, hn, hnonprim⟩ => ?_
+    refine (checkNoMVarNoFVar.WF _ _ _).bind fun _ h => ?_
+    have ⟨vesA, wfA, hstepA⟩ := addConst.WF wf (.axiomInfo { v with isUnsafe := true }) ci0
+      .unsafe (fun _ => id) ⟨⟨DefinitionSafety.unsafe_le, htr.1.2.1, htr.1.2.2⟩, htr.2⟩
+      hwfc hn (hnonprim rfl) fun _ _ htr' hci' hadd' old =>
+        .axiom htr' (by rwa [← old.map_wf.find?'_eq_find?]) hci' hadd' old
+    have hadd := (hstepA .unsafe).2.2
+    refine checkBodyCore.WF (wfA.toVEnvAt .unsafe) (.defnDecl v)
+      v.levelParams v.type v.value ci0.type (htr.1.2.2.mono (VEnv.addConst_le hadd)) h
+      |>.run1 _ |>.bind fun _ h3 => ?_
+    obtain ⟨value', hvalue, hvalueType⟩ := h3
+    have hciWF : (⟨ci0, value'⟩ : VDefVal).WF (vesA.venv .unsafe) := by
+      show (vesA.venv .unsafe).HasType ci0.uvars [] value' ci0.type
+      rw [← htr.1.2.1]; exact hvalueType
+    have ⟨ves', hwf', hmono'⟩ := addUnsafeDef.WF wf v ⟨ci0, value'⟩ (vesA.venv .unsafe)
+      ‹_› htr hwfc hadd hvalue hciWF hn (hnonprim rfl)
+    exact .pure ⟨ves', hwf', hmono', (nomatch · ‹_›)⟩
+  refine (checkDefinition.WF wf v).run wf |>.bind
+    fun _ ⟨allow, ci', hp, hu, ht, hname, hvalue, hci, hfresh, hnonprim⟩ => ?_
+  have hle : v.safety ≤ .safe := DefinitionSafety.le_safe
+  have hmono := wf.mono hle
+  have htr : TrDefVal v.safety (ves.venv v.safety) (.defnInfo v) ci' := by
+    refine ⟨⟨⟨?_, hu, ht.mono hmono⟩, hname⟩, hvalue.mono hmono⟩
+    rw [ConstantInfo.defnInfo_safety]
+    exact DefinitionSafety.le_rfl
+  have ⟨ves', hwf, hstep⟩ := addDef.WF wf v ci' v.safety ?_ htr (hci.mono hmono) hfresh ?_ ?_
+  · exact .pure ⟨ves', hwf, (hstep · |>.le), fun _ => ⟨ci', hstep⟩⟩
+  · simp [ConstantInfo.defnInfo_safety]
+  · intro hnamePrim; have := mt hnonprim; simp [hnamePrim] at this
+    exact ⟨by rw [ConstantInfo.defnInfo_safety, hp.safe this], hp.no_level_params this⟩
+  · intro safety base hvisible hadd
+    have hs : safety ≤ v.safety := by simpa [ConstantInfo.defnInfo_safety] using hvisible
+    have hsf : TrDefVal safety (ves.venv v.safety) (.defnInfo v) ci' :=
+      ⟨⟨htr.1.1.sf_mono hs, htr.1.2⟩, htr.2⟩
+    have hci' := hci.mono (hmono.trans (wf.mono hs))
+    cases allow
+    · exact (wf.hasPrimitives.addConst_of_not_primitive (hnonprim rfl) hadd).addDefEq
+    · exact hp.preserves rfl (wf.mono DefinitionSafety.le_safe) wf.tr.wf wf.hasPrimitives
+        (hsf.mono (wf.mono hs)) (hci.mono (hmono.trans (wf.mono hs))) hadd
+
+theorem addTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : TheoremVal) :
+    (addTheorem env v).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety,
+        (ves.venv safety).AddConst safety (.thmInfo v) ci'.toVConstant (ves'.venv safety) := by
+  refine (checkTheorem.WF wf v).run wf |>.bind fun _ h => ?_
+  obtain ⟨ci', htr, hbody, hprop, hn, hnonprim⟩ := h
+  have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.thmInfo v) ci'.toVConstVal .safe
+    (fun _ _ => DefinitionSafety.le_safe) htr.1 ⟨_, hprop⟩ hn hnonprim
+    fun safety _ hheader _ hadd old => ?_
+  · exact .pure ⟨ves', hwf, ci'.toVConstVal, hstep⟩
+  have hle := wf.mono hheader.1
+  have htr' : TrDefVal safety (ves.venv safety) (.thmInfo v) ci' :=
+    ⟨⟨hheader, htr.1.2⟩, htr.2.mono hle⟩
+  exact .thm htr' (by rwa [← old.map_wf.find?'_eq_find?]) (hbody.mono hle)
+    (hprop.mono hle) hadd old
+
+theorem addOpaque.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : OpaqueVal) :
+    (addOpaque env v).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety,
+        (ves.venv safety).AddConst safety (.opaqueInfo v) ci'.toVConstant (ves'.venv safety) := by
+  let checkSafety : DefinitionSafety := if v.isUnsafe then .unsafe else .safe
+  have hsafety : (ConstantInfo.opaqueInfo v).safety = checkSafety := by
+    cases v.isUnsafe <;> rfl
+  refine (checkOpaque.WF wf v).run wf |>.bind fun _ h => ?_
+  obtain ⟨ci', hu, ht, hname, hvalue, hciC, hci, hfresh, hnonprim⟩ := h
+  have hle : checkSafety ≤ .safe := DefinitionSafety.le_safe
+  have hmono := wf.mono hle
+  have htr : TrConstVal checkSafety (ves.venv checkSafety) (.opaqueInfo v) ci'.toVConstVal :=
+    ⟨⟨hsafety.symm ▸ DefinitionSafety.le_rfl, hu, ht.mono hmono⟩, hname⟩
+  have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.opaqueInfo v) ci'.toVConstVal checkSafety ?_ htr
+    (hciC.mono hmono) hfresh hnonprim fun safety _ htr hciW hadd old => ?_
+  · exact .pure ⟨ves', hwf, ci'.toVConstVal, hstep⟩
+  · intro safety hvisible
+    rwa [hsafety] at hvisible
+  · have hvis : safety ≤ checkSafety := hsafety ▸ htr.1
+    have hto := hmono.trans (wf.mono hvis)
+    exact .opaque (ci' := ci') ⟨⟨htr, hname⟩, hvalue.mono hto⟩
+      (by rwa [← old.map_wf.find?'_eq_find?]) (hci.mono hto) hadd old
+
+/- Tier V (L4L-19B): upstream's v4.33 proof of this statement was vacuous —
+it derived `False` from a successful `checkEqType` run via
+`TrEnv'.no_inductInfo`, which is refutable on this fork (the inductive
+verification boundary is implemented, so a translated environment can
+contain the real `Eq`, and quotient initialization can genuinely succeed).
+That auxiliary lemma was deleted at the reconciliation; the constructive
+proof connects `checkEqType`/`Environment.addQuot` success to the Theory
+quotient transaction (`VEnv.addQuot`, `addQuot_WF`) and is checker-closure
+work, not merge resolution. -/
+theorem addQuot.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) :
+    (Environment.addQuot env).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by
   sorry
+
+private theorem Except.WF.throw' {e : ε} {Q : α → Prop} : (throw e : Except ε α).WF Q :=
+  fun _ h => nomatch h
+
+private theorem Except.WF.throwBind {e : ε} {f : α → Except ε β} {Q : β → Prop} :
+    ((throw e : Except ε α) >>= f).WF Q := fun _ h => nomatch h
+
+theorem addMutual.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (vs : List DefinitionVal) :
+    (addMutual env vs).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by
+  unfold addMutual
+  simp only [reduceIte]
+  split <;> [rename_i _ v₀ rest; exact Except.WF.throw']
+  split <;> [exact Except.WF.throwBind; skip]
+  have hsf : v₀.safety ≤ (if v₀.safety == .unsafe then .unsafe else .safe) := by
+    cases v₀.safety with
+    | «partial» => exact DefinitionSafety.le_safe
+    | _ => exact DefinitionSafety.le_rfl
+  refine (TypeChecker.M.WF.run (Q := fun _ =>
+    (∃ cis, (v₀ :: rest).Forall₂ (fun v ci =>
+      TrMutualHeader v₀.safety (ves.venv v₀.safety) env v ci ∧
+      v.safety = v₀.safety ∧ v.levelParams = v₀.levelParams) cis) ∧
+    (((v₀ :: rest).map (·.name)).Nodup ∧
+      ∀ v ∈ (v₀ :: rest), (∅ : NameSet).contains v.name = false)) wf ?_).bind fun _ h1 => ?_
+  · refine (TypeChecker.M.WF.forInFresh fun v found s => ?_).bind fun _ _ _ h => .pure h
+    split <;> [exact .bindThrow .throw; rename_i hsafety]
+    split <;> [exact .bindThrow .throw; rename_i hlp]
+    split <;> [exact .bindThrow .throw; rename_i hfound]
+    simp at hsafety hlp hfound
+    rw [← hlp]
+    refine (checkConstantVal.WF wf (.defnInfo v) false ?_ s).bind ?_
+    · rw [ConstantInfo.defnInfo_safety, hsafety]; exact DefinitionSafety.le_rfl
+    refine fun _ _ _ ⟨ci', htr, hciw, hn, hnp⟩ => .pure ?_
+    exact ⟨hfound, ⟨⟨ci', .bvar 0⟩, ⟨htr, hciw, hn, hnp rfl⟩, hsafety, rfl⟩, rfl⟩
+  obtain ⟨⟨cis0, hQ0⟩, hnd, -⟩ := h1
+  have hhdr := hQ0.imp fun _ _ h => h.1
+  have hpull {P : DefinitionVal → VDefVal → Prop} (h : List.Forall₂ P (v₀ :: rest) cis0)
+      {R : DefinitionVal → Prop} (H : ∀ v ci, P v ci → R v) : ∀ v ∈ v₀ :: rest, R v :=
+    fun v hv => have ⟨ci, _, hp⟩ := h.forall_exists_l v hv; H v ci hp
+  have hbs := hpull hQ0 fun _ _ h => h.2.1
+  have hfresh := hpull hhdr fun _ _ h => h.2.2.1
+  have hnonprim := hpull hhdr fun _ _ h => h.2.2.2
+  have hnameeq : (v₀ :: rest).map (·.name) = cis0.map (·.name) := by
+    rw [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff]
+    exact hhdr.imp fun _ _ h => h.1.2
+  have hpullr {P : DefinitionVal → VDefVal → Prop} (h : List.Forall₂ P (v₀ :: rest) cis0)
+      {R : VDefVal → Prop} (H : ∀ v ci, P v ci → R ci) : ∀ ci ∈ cis0, R ci :=
+    fun ci hc => have ⟨v, _, hp⟩ := h.forall_exists_r ci hc; H v ci hp
+  obtain ⟨base, hbase0⟩ := (wf.tr (safety := v₀.safety)).exists_addConsts
+    (hpullr hhdr fun _ _ h => h.1.2 ▸ h.2.2.1) (hnameeq ▸ hnd)
+  have wfA := VEnvAt.addAxioms hsf (wf.toVEnvAt v₀.safety) hhdr hnd hbase0
+  refine (TypeChecker.M.WF.run1 (Q := fun _ => ∃ cis',
+    cis0.Forall₂ (fun (ci ci' : VDefVal) => ci.toVConstVal = ci'.toVConstVal) cis' ∧
+    (v₀ :: rest).Forall₂ (fun v ci' => TrExprS base v.levelParams [] v.value ci'.value ∧
+      ci'.WF base) cis') wfA ?_).bind fun _ h2 => ?_
+  · refine (TypeChecker.M.WF.forInForall₂ (fun v ci s hd => ?_) hQ0).bind fun _ _ _ h => .pure h
+    have hdecl := hd.1.1.1.2.2.mono (VEnv.addConsts_le hbase0)
+    refine (TypeChecker.M.WF.liftExcept
+      (checkNoMVarNoFVar.WF _ v.name v.value)).bind fun _ _ _ hclosed => ?_
+    have hclosed' : v.value.FVarsIn
+        (· ∈ (TypeChecker.VContext.mk1 wfA v.levelParams).vlctx.fvars) := by
+      simpa [TypeChecker.VContext.mk1] using hclosed
+    refine hd.2.2 ▸ (TypeChecker.checkType.WF hclosed').bind
+      fun valType _ _ ⟨value', valType', _, hval, hvalTy, hhasType⟩ => ?_
+    refine (TypeChecker.isDefEq.WF hvalTy hdecl).bind fun equal _ _ hequal => ?_
+    split <;> [exact .bindThrow .throw; rename_i heq]
+    refine .pure ⟨⟨⟨ci.toVConstVal, value'⟩, rfl, hval, ?_⟩, rfl⟩
+    rw [VDefVal.WF, ← hd.1.1.1.2.1]
+    exact hhasType.defeqU_r wfA.tr.wf (by trivial) (hequal (by simpa using heq))
+  obtain ⟨cis, hRR, hbody⟩ := h2
+  rw [VEnv.addConsts_congr hRR] at hbase0
+  have : List.Forall₂ (TrMutualHeader v₀.safety (ves.venv v₀.safety) env) (v₀ :: rest) cis :=
+    hhdr.trans (h₂ := hRR) fun v ci ci' h1 h2 => by
+      have hc : ci.toVConstant = ci'.toVConstant := congrArg VConstVal.toVConstant h2
+      exact ⟨h2 ▸ h1.1, hc ▸ h1.2.1, h1.2.2.1, h1.2.2.2⟩
+  refine .pure <| addMutualBlock.WF wf v₀.safety (v₀ :: rest) cis base hbs hnd hfresh hnonprim
+    (fun ci hc => ?_) hbase0 ((this.and hbody).imp (fun _ _ h => ⟨h.1.1, h.2.1⟩)) (fun ci hc => ?_)
+  · obtain ⟨v, -, h⟩ := this.forall_exists_r ci hc; exact h.2.1
+  · obtain ⟨v, -, h⟩ := hbody.forall_exists_r ci hc; exact h.2
+
+/-- Successful checked addition preserves well-formedness and extends every safety-indexed
+abstract environment. The only declaration form still outstanding is inductives, which need a
+constructive `AddInduct` model. -/
+theorem addDecl.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (decl : Declaration) :
+    (addDecl env decl (check := true) (fuel := {})).WF fun env' =>
+      ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by
+  cases decl with
+  | axiomDecl v => exact (addAxiom.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩
+  | thmDecl v => exact (addTheorem.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩
+  | defnDecl v => exact (addDefinition.WF wf v).mono fun _ ⟨ves', hwf, h, _⟩ => ⟨ves', hwf, h⟩
+  | opaqueDecl v =>
+    exact (addOpaque.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩
+  | quotDecl => exact addQuot.WF wf
+  | mutualDefnDecl vs => exact addMutual.WF wf vs
+  | inductDecl _ _ _ _ => sorry
diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean
index c5102ead..f981b5e4 100644
--- a/Lean4Lean/Verify/Environment/Basic.lean
+++ b/Lean4Lean/Verify/Environment/Basic.lean
@@ -26,7 +26,43 @@ def TrConstVal (ci : ConstantInfo) (ci' : VConstVal) : Prop :=
 variable (safety : DefinitionSafety) (env : VEnv) in
 def TrDefVal (ci : ConstantInfo) (ci' : VDefVal) : Prop :=
   TrConstVal safety env ci ci'.toVConstVal ∧
-  TrExprS env ci.levelParams [] ci.value! ci'.value
+  TrExprS env ci.levelParams [] (ci.value! (allowOpaque := true)) ci'.value
+
+/-- The step an abstract environment takes when `ci`, modelled by `ci'`, is added.
+
+At safety levels where the declaration is visible the constant is added; where it is not, the
+environment is unchanged, matching `TrEnv'.ignore`. Stating this rather than just `venv ≤ venv'`
+is what lets a caller see *which* constant a step added. -/
+def VEnv.AddConst (venv : VEnv) (safety : DefinitionSafety) (ci : ConstantInfo)
+    (ci' : VConstant) (venv' : VEnv) : Prop :=
+  if safety ≤ ci.safety then
+    TrConstant safety venv ci ci' ∧ ci'.WF venv ∧ venv.addConst ci.name ci' = some venv'
+  else
+    venv' = venv
+
+theorem VEnv.AddConst.le {venv venv' : VEnv} {ci ci'}
+    (H : VEnv.AddConst venv safety ci ci' venv') : venv ≤ venv' := by
+  unfold VEnv.AddConst at H; split at H
+  · exact addConst_le H.2.2
+  · exact H ▸ VEnv.LE.rfl
+
+/-- As `VEnv.AddConst`, for a definition: the constant is added and then its defining equation,
+matching `TrEnv'.defn`. -/
+def VEnv.AddDef (venv : VEnv) (safety : DefinitionSafety) (ci : ConstantInfo)
+    (ci' : VDefVal) (venv' : VEnv) : Prop :=
+  if safety ≤ ci.safety then
+    ∃ base, TrDefVal safety venv ci ci' ∧ ci'.WF venv ∧
+      venv.addConst ci.name ci'.toVConstant = some base ∧
+      venv' = base.addDefEq ci'.toDefEq
+  else
+    venv' = venv
+
+theorem VEnv.AddDef.le {venv venv' : VEnv} {ci ci'}
+    (H : VEnv.AddDef venv safety ci ci' venv') : venv ≤ venv' := by
+  unfold VEnv.AddDef at H; split at H
+  · obtain ⟨base, _, _, hadd, rfl⟩ := H
+    exact (addConst_le hadd).trans (VEnv.addDefEq_le ..)
+  · exact H ▸ VEnv.LE.rfl
 
 def AddQuot1 (name : Name) (kind : QuotKind) (ci' : VConstant) (P : ConstMap → VEnv → Prop)
     (m : ConstMap) (env : VEnv) : Prop :=
@@ -196,6 +232,35 @@ def AddInductBlock (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl)
     (m₂ : ConstMap) (env₂ : VEnv) : Prop :=
   Nonempty (AddInductBlockTrace m₁ env₁ decl m₂ env₂)
 
+/-- Data-bearing alignment trace for a nested inductive declaration: the
+source families and constructors are the stored payload, followed by the
+restored recursors and restored rules.  The implementation map receives
+only restored metadata; no auxiliary constant appears in either the map or
+the Theory environment. -/
+structure AddInductNestedTrace
+    (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl)
+    (m₂ : ConstMap) (env₂ : VEnv) where
+  nested : decl.NestedBlockChecked
+  nested_wf : nested.WF env₁
+  typeMap : ConstMap
+  typeEnv : VEnv
+  ctorMap : ConstMap
+  ctorEnv : VEnv
+  recEnv : VEnv
+  addTypes : AddInductConstants .induct m₁ env₁
+    decl.blockTypeConstants typeMap typeEnv
+  addCtors : AddInductConstants .ctor typeMap typeEnv
+    decl.blockConstructorConstants ctorMap ctorEnv
+  addRecs : AddInductConstants .recursor ctorMap ctorEnv
+    nested.recursors m₂ recEnv
+  recK : RecursorMapKMatches m₂ nested.recursors nested.generation.kTarget
+  addRules : AddDefEqs recEnv nested.generatedRules env₂
+
+/-- Proposition-valued alignment for a nested declaration. -/
+def AddInductNested (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl)
+    (m₂ : ConstMap) (env₂ : VEnv) : Prop :=
+  Nonempty (AddInductNestedTrace m₁ env₁ decl m₂ env₂)
+
 theorem AddInductConstants.to_foldlM :
     AddInductConstants kind m₁ env₁ cis m₂ env₂ →
     List.foldlM (fun env (ci : VConstVal) => env.addConst ci.name ci.toVConstant) env₁ cis =
@@ -270,6 +335,12 @@ theorem AddInductBlockTrace.to_addInductBlockGeneration
   simp [VEnv.addInductBlockGeneration, H.addTypes.to_foldlM,
     H.addCtors.to_foldlM, H.addRecs.to_foldlM, H.addRules.to_add]
 
+theorem AddInductNestedTrace.to_addInductNested
+    (H : AddInductNestedTrace m₁ env₁ decl m₂ env₂) :
+    env₁.addInductNested H.nested = some env₂ := by
+  simp [VEnv.addInductNested, H.addTypes.to_foldlM,
+    H.addCtors.to_foldlM, H.addRecs.to_foldlM, H.addRules.to_add]
+
 /-- Recover the exact certified normalized Theory transaction represented by
 an implementation metadata replay. This replaces the old, false-for-aliases
 claim that every replay must pass the identity-only `VEnv.addInduct` wrapper. -/
@@ -303,51 +374,79 @@ theorem AddInductBlock.le
   rcases VEnv.addInductBlockGeneration_trace hadd with ⟨trace⟩
   exact trace.le
 
-/- The Verify relation currently mentions `TrExprS`, whose projection branch
-mentions the still-sorried `TrProj`. These guards make that inherited debt
-visible and will fail (intentionally) when Track P removes `sorryAx`. -/
+/-- Recover the exact nested Theory transaction represented by an
+implementation metadata replay. -/
+theorem AddInductNested.to_addInductNested
+    (H : AddInductNested m₁ env₁ decl m₂ env₂) :
+    ∃ nested : decl.NestedBlockChecked,
+      nested.WF env₁ ∧ env₁.addInductNested nested = some env₂ := by
+  rcases H with ⟨H⟩
+  exact ⟨H.nested, H.nested_wf, H.to_addInductNested⟩
+
+theorem AddInductNested.le
+    (H : AddInductNested m₁ env₁ decl m₂ env₂) : env₁ ≤ env₂ := by
+  obtain ⟨nested, -, hadd⟩ := H.to_addInductNested
+  exact VEnv.addInductNested_le hadd
+
+/- The projection relation is now a concrete Theory proposition, so merely
+mentioning `TrExprS` no longer contaminates these projection-free roots with
+the deferred structural-law sorries. -/
 /--
-info: 'Lean4Lean.AddInductTrace.to_addInductGeneration' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.AddInductTrace.to_addInductGeneration' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInductTrace.to_addInductGeneration
 
 /--
-info: 'Lean4Lean.AddInduct.to_addInduct' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.AddInduct.to_addInduct' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInduct.to_addInduct
 
 /--
-info: 'Lean4Lean.AddInduct.le' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.AddInduct.le' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInduct.le
 
 /--
-info: 'Lean4Lean.AddInductBlockTrace.to_addInductBlockGeneration' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.AddInductBlockTrace.to_addInductBlockGeneration' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInductBlockTrace.to_addInductBlockGeneration
 
 /--
-info: 'Lean4Lean.AddInductBlock.to_addInductBlock' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.AddInductBlock.to_addInductBlock' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInductBlock.to_addInductBlock
 
 /--
-info: 'Lean4Lean.AddInductBlock.le' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.AddInductBlock.le' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms AddInductBlock.le
 
+/-- Insert a whole block of definitions into the constant map. -/
+def insertDefs (C : ConstMap) (cis : List DefinitionVal) : ConstMap :=
+  cis.foldl (fun C ci => C.insert ci.name (.defnInfo ci)) C
+
+variable (safety : DefinitionSafety) (env env' : VEnv) in
+/-- Translation data for a mutual block: the headers are translated against the environment
+before the block is added, the values against the environment that already has every constant
+of the block, mirroring the kernel adding them all as axioms first. -/
+def TrDefBlock (cis : List DefinitionVal) (cis' : List VDefVal) : Prop :=
+  List.Forall₂ (fun ci ci' =>
+    TrConstVal safety env (.defnInfo ci) ci'.toVConstVal ∧
+    TrExprS env' ci.levelParams [] ci.value ci'.value) cis cis'
+
 variable (safety : DefinitionSafety) in
 inductive TrEnv' : ConstMap → Bool → VEnv → Prop where
   | empty : TrEnv' {} false .empty
+  | ignore :
+    C.find? ci.name = none → ¬safety ≤ ci.safety →
+    TrEnv' C Q env →
+    TrEnv' (C.insert ci.name ci) Q env
   | axiom :
     TrConstant safety env (.axiomInfo ci) ci' →
     C.find? ci.name = none → ci'.WF env →
@@ -360,6 +459,24 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where
     env.addConst ci.name ci'.toVConstant = some env' →
     TrEnv' C Q env →
     TrEnv' (C.insert ci.name (.defnInfo ci)) Q (env'.addDefEq ci'.toDefEq)
+  /-- A mutual block, and an unsafe definition as the one-element case. -/
+  | mutualDef {cis : List DefinitionVal} {cis' : List VDefVal} :
+    TrDefBlock safety env env' cis cis' →
+    -- the block's names are distinct; `addMutual` checks this, as does lean4#14632
+    (cis.map (·.name)).Nodup →
+    (∀ ci ∈ cis, C.find? ci.name = none) →
+    (∀ ci' ∈ cis', ci'.toVConstant.WF env) →
+    env.addConsts cis' = some env' →
+    (∀ ci' ∈ cis', ci'.WF env') →
+    TrEnv' C Q env →
+    TrEnv' (insertDefs C cis) Q (env'.addDefEqs cis')
+  | thm {ci' : VDefVal} :
+    TrDefVal safety env (.thmInfo ci) ci' →
+    C.find? ci.name = none → ci'.WF env →
+    env.HasType ci'.uvars [] ci'.type (.sort .zero) →
+    env.addConst ci.name ci'.toVConstant = some env' →
+    TrEnv' C Q env →
+    TrEnv' (C.insert ci.name (.thmInfo ci)) Q env'
   | opaque {ci' : VDefVal} :
     TrDefVal safety env (.opaqueInfo ci) ci' →
     C.find? ci.name = none → ci'.WF env →
@@ -390,6 +507,18 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where
     AddInductBlock C env decl C' env' →
     TrEnv' C Q env →
     TrEnv' C' Q env'
+  | inductNested :
+    AddInductNested C env decl C' env' →
+    TrEnv' C Q env →
+    TrEnv' C' Q env'
+  /-- Register a Theory structure-eta descriptor without changing the host
+  constant map.  Host eligibility and exact view alignment are retained by
+  `StructureEtaArtifact`; this history step records only the checked Theory
+  capability and its subject-reduction certificate. -/
+  | structEta :
+    rule.WF env →
+    TrEnv' C Q env →
+    TrEnv' C Q (env.addStructEta rule)
 
 def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop :=
   TrEnv' safety env.constants env.quotInit venv
@@ -397,6 +526,7 @@ def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop :
 theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by
   induction H with
   | empty => exact ⟨_, .empty⟩
+  | ignore _ _ _ ih => exact ih
   | «axiom» _ _ h1 h2 _ ih =>
     have ⟨_, H⟩ := ih
     exact ⟨_, H.decl <| .axiom (ci := ⟨_, _⟩) h1 h2⟩
@@ -404,6 +534,14 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by
     have ⟨_, H⟩ := ih
     have := h1.1.2; dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at this
     exact ⟨_, H.decl <| .def h2 (this ▸ h3)⟩
+  | mutualDef _ _ _ h2 h3 h4 _ ih =>
+    have ⟨_, H⟩ := ih
+    exact ⟨_, H.decl <| .mutualDef h2 h3 h4⟩
+  | thm h1 _ h2 h3 h4 _ ih =>
+    have ⟨_, H⟩ := ih
+    have hn := h1.1.2
+    dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at hn
+    exact ⟨_, (H.decl (.example h2)).decl (.axiom ⟨_, h3⟩ (hn ▸ h4))⟩
   | «opaque» h1 _ h2 h3 _ ih =>
     have ⟨_, H⟩ := ih
     have := h1.1.2; dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at this
@@ -423,9 +561,16 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by
     obtain ⟨generation, blockEnv, hgen, hadd⟩ :=
       h1.to_addInductBlock
     exact ⟨_, H.decl <| .inductBlock (blockEnv := blockEnv) hgen hadd⟩
+  | inductNested h1 _ ih =>
+    have ⟨_, H⟩ := ih
+    obtain ⟨nested, hwf, hadd⟩ := h1.to_addInductNested
+    exact ⟨_, H.decl <| .inductNested hwf hadd⟩
+  | structEta hrule _ ih =>
+    have ⟨_, H⟩ := ih
+    exact ⟨_, H.structEta hrule⟩
 
 /--
-info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TrEnv'.wf
diff --git a/Lean4Lean/Verify/Environment/Boundaries.lean b/Lean4Lean/Verify/Environment/Boundaries.lean
new file mode 100644
index 00000000..5b800d2a
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/Boundaries.lean
@@ -0,0 +1,35 @@
+import Lean4Lean.Verify.TypeChecker
+import Lean4Lean.Environment
+
+/-!
+This module contains the front-end-specific trust boundary for declaration verification.
+The checker, extension, and declaration modules introduce no additional `sorry`-backed
+assumptions. The imported type-checker and theory layers retain their own explicit
+verification gaps.
+-/
+
+namespace Lean4Lean
+
+open Lean hiding Environment Exception
+open Kernel
+
+/-- What the primitive-definition recognizer must establish beyond ordinary type checking.
+This is kept separate from declaration checking so that the remaining metatheory does not
+depend on the recognizer's syntactic implementation. Primitive semantics are claimed only
+in well-formed extensions of the environment in which recognition ran. -/
+structure PrimitiveResult (checked : VEnv) (v : DefinitionVal) (allow : Bool) : Prop where
+  safe : allow = true → v.safety = .safe
+  no_level_params : allow = true → v.levelParams = []
+  preserves : allow = true → ∀ {safety : DefinitionSafety} {venv env' : VEnv} {ci' : VDefVal},
+    checked ≤ venv → venv.WF →
+    venv.HasPrimitives →
+    TrDefVal safety venv (.defnInfo v) ci' → ci'.WF venv →
+    venv.addConst v.name ci'.toVConstant = some env' →
+    (env'.addDefEq ci'.toDefEq).HasPrimitives
+
+/-- Verification boundary for Lean4Lean's syntactic primitive-definition recognizer. -/
+theorem checkPrimitiveDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : DefinitionVal) :
+    (Environment.checkPrimitiveDef v).WF (.mk' wf .safe v.levelParams) {} fun allow _ =>
+      PrimitiveResult (ves.venv .safe) v allow := by
+  sorry
diff --git a/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean b/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean
index 50f01b7e..e6f5fbf6 100644
--- a/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean
+++ b/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean
@@ -276,11 +276,11 @@ private theorem candidateWhnfCoreFVar_refl
     (context : AddInductive.Context) (id : FVarId)
     (state : TypeChecker.State)
     (hnotlet : TypeChecker.Inner.isLetFVar context.lctx id = false) :
-    TypeChecker.Inner.whnfCore (.fvar id) false false
+    TypeChecker.Inner.whnfCore (.fvar id) false
         (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker state =
       .ok (.fvar id, state) := by
-  change TypeChecker.Inner.whnfCore' (.fvar id) false false
+  change TypeChecker.Inner.whnfCore' (.fvar id) false
       (TypeChecker.Methods.withFuel 9998)
       context.toTypeChecker state =
     .ok (.fvar id, state)
@@ -298,7 +298,7 @@ private theorem candidateReduceRecursorFVarApp_none
     (state : TypeChecker.State)
     (hquot : context.env.quotInit = false) :
     TypeChecker.Inner.reduceRecursor
-        (.app (.fvar fnId) (.fvar argId)) false false
+        (.app (.fvar fnId) (.fvar argId))
         (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker state =
       .ok (none, state) := by
@@ -322,7 +322,7 @@ private theorem candidateWhnfCoreFVarAppFVar_refl
     (hquot : context.env.quotInit = false)
     (hnotlet : TypeChecker.Inner.isLetFVar context.lctx fnId = false) :
     TypeChecker.Inner.whnfCore'
-        (.app (.fvar fnId) (.fvar argId)) false false
+        (.app (.fvar fnId) (.fvar argId)) false
         (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker ({} : TypeChecker.State) =
       .ok (.app (.fvar fnId) (.fvar argId),
@@ -477,7 +477,7 @@ theorem candidateWhnfFVarAppFVar_refl
 private theorem candidateWhnfCoreConst_refl
     (context : AddInductive.Context) (constName : Name)
     (levels : List Level) (state : TypeChecker.State) :
-    TypeChecker.Inner.whnfCore (.const constName levels) false false
+    TypeChecker.Inner.whnfCore (.const constName levels) false
         (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker state =
       .ok (.const constName levels, state) := by
@@ -491,7 +491,7 @@ private theorem candidateReduceRecursorConstFVarFVar_none
     (hfind : context.env.find? constName = some (.inductInfo info)) :
     TypeChecker.Inner.reduceRecursor
         (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2))
-        false false (TypeChecker.Methods.withFuel 9999)
+        (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker state = .ok (none, state) := by
   unfold TypeChecker.Inner.reduceRecursor
   simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind]
@@ -518,7 +518,7 @@ private theorem candidateWhnfCoreConstFVarFVar_refl
     (hfind : context.env.find? constName = some (.inductInfo info)) :
     TypeChecker.Inner.whnfCore'
         (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2))
-        false false (TypeChecker.Methods.withFuel 9999)
+        false (TypeChecker.Methods.withFuel 9999)
         context.toTypeChecker ({} : TypeChecker.State) =
       .ok (.app (.app (.const constName levels) (.fvar arg1))
         (.fvar arg2), ({} : TypeChecker.State)) := by
diff --git a/Lean4Lean/Verify/Environment/Checker.lean b/Lean4Lean/Verify/Environment/Checker.lean
new file mode 100644
index 00000000..60e6cdb7
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/Checker.lean
@@ -0,0 +1,247 @@
+import Lean4Lean.Verify.Environment.Boundaries
+
+namespace Lean4Lean
+
+open Lean hiding Environment Exception
+open Kernel
+
+theorem ConstantInfo.defnInfo_safety (v : DefinitionVal) :
+    (ConstantInfo.defnInfo v).safety = v.safety := by
+  simp [ConstantInfo.safety, ConstantInfo.isUnsafe, ConstantInfo.isPartial]
+  cases v.safety <;> rfl
+
+theorem checkName.WF (mapWF : env.constants.WF) (name : Name) (allowPrimitive : Bool) :
+    (Environment.checkName env name allowPrimitive).WF fun _ =>
+      env.find? name = none ∧ (allowPrimitive = false → Environment.primitives.contains name = false) := by
+  intro _ h
+  have hn : env.contains name = false := by
+    cases hfind : env.contains name
+    · rfl
+    · simp [Environment.checkName, hfind, (· >>= ·), Except.bind] at h
+  change env.constants.contains name = false at hn
+  rw [SMap.find?_isSome] at hn
+  constructor
+  · rw [Kernel.Environment.find?, mapWF.find?'_eq_find?]
+    cases hfind : env.constants.find? name <;> simp_all
+  · intro ha
+    cases hp : Environment.primitives.contains name
+    · rfl
+    · have hc : env.contains name = false := by
+        change env.constants.contains name = false
+        rw [SMap.find?_isSome]
+        exact hn
+      simp only [Environment.checkName, hc, ha, hp, ↓reduceIte] at h
+      rw [show (pure PUnit.unit : Except Exception PUnit) = .ok PUnit.unit from rfl] at h
+      contradiction
+
+private theorem checkNoMVar.WF (env : Environment) (name : Name) (e : Expr) :
+    (Environment.checkNoMVar env name e).WF fun _ => e.hasMVar = false := by
+  intro _ h
+  cases hmv : e.hasMVar
+  · rfl
+  · simp [Environment.checkNoMVar, hmv] at h
+
+private theorem checkNoFVar.WF (env : Environment) (name : Name) (e : Expr) :
+    (Environment.checkNoFVar env name e).WF fun _ => e.hasFVar = false := by
+  intro _ h
+  cases hfv : e.hasFVar
+  · rfl
+  · simp [Environment.checkNoFVar, hfv] at h
+
+theorem checkNoMVarNoFVar.WF (env : Environment) (name : Name) (e : Expr) :
+    (Environment.checkNoMVarNoFVar env name e).WF fun _ => e.FVarsIn fun _ => False := by
+  unfold Environment.checkNoMVarNoFVar
+  refine (checkNoMVar.WF env name e).bind fun _ hm =>
+    (checkNoFVar.WF env name e).mono fun _ hf => ?_
+  apply fvarsIn_iff.2
+  refine ⟨?_, fvarsIn_iff_hasMVar.2 hm⟩
+  intro fv hmem
+  rw [fvarsList_eq_nil.2 hf] at hmem
+  simp at hmem
+
+private theorem Except.WF.trivial (x : Except ε α) : x.WF fun _ => True :=
+  fun _ _ => True.intro
+
+private theorem TypeChecker.M.WF.pureBind {c : TypeChecker.VContext}
+    {s : TypeChecker.VState} {f : β → TypeChecker.M α} {Q} {x : β}
+    (H : (f x).WF c s Q) : ((Pure.pure x : TypeChecker.M β) >>= f).WF c s Q := H
+
+theorem checkConstantValCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (ci : ConstantInfo) (allowPrimitive : Bool) (state : TypeChecker.VState := {}) :
+    (checkConstantVal env ci.toConstantVal allowPrimitive).WF
+      (.mk' wf safety ci.levelParams) state fun _ _ =>
+        ∃ ci' : VConstVal,
+          ci.levelParams.length = ci'.uvars ∧
+          TrExprS (ves.venv safety) ci.levelParams [] ci.type ci'.type ∧
+          ci.name = ci'.name ∧
+          ci'.toVConstant.WF (ves.venv safety) ∧ env.find? ci.name = none ∧
+          (allowPrimitive = false → Environment.primitives.contains ci.name = false) := by
+  unfold checkConstantVal
+  refine (TypeChecker.M.WF.liftExcept
+    (checkName.WF (wf.tr (safety := safety)).map_wf ci.name allowPrimitive)).bind
+    fun _ _ _ hname => ?_
+  -- Duplicate level parameters are rejected operationally; no later proof needs that fact.
+  refine (TypeChecker.M.WF.liftExcept (Except.WF.trivial _)).bind fun _ _ _ _ => ?_
+  refine (TypeChecker.M.WF.liftExcept
+    (checkNoMVarNoFVar.WF env ci.name ci.type)).bind fun _ _ _ hclosed => ?_
+  have hclosed' : ci.type.FVarsIn (· ∈ (TypeChecker.VContext.mk' wf safety ci.levelParams).vlctx.fvars) := by
+    simpa [TypeChecker.VContext.mk', TypeChecker.VContext.mk1] using hclosed
+  refine (TypeChecker.checkType.WF hclosed').bind
+    fun _ _ _ ⟨type', sort', _, htype, hsort, hhasType⟩ => ?_
+  refine (TypeChecker.ensureSort.WF hsort).bind
+    fun _ _ _ ⟨⟨_, hsort', hdefeq⟩, hsortEq⟩ => .pure ?_
+  obtain ⟨u, rfl⟩ := hsortEq
+  cases hsort' with
+  | sort hu =>
+    refine ⟨{ name := ci.name, uvars := ci.levelParams.length, type := type' },
+      rfl, htype, rfl, ?_, hname⟩
+    exact ⟨_, hhasType.defeqU_r (wf.tr (safety := safety)).wf (by trivial) hdefeq.symm⟩
+
+theorem checkConstantVal.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (ci : ConstantInfo) (allowPrimitive : Bool) (hs : safety ≤ ci.safety)
+    (state : TypeChecker.VState := {}) :
+    (checkConstantVal env ci.toConstantVal allowPrimitive).WF
+      (.mk' wf safety ci.levelParams) state fun _ _ =>
+        ∃ ci' : VConstVal, TrConstVal safety (ves.venv safety) ci ci' ∧
+          ci'.toVConstant.WF (ves.venv safety) ∧ env.find? ci.name = none ∧
+          (allowPrimitive = false → Environment.primitives.contains ci.name = false) := by
+  exact (checkConstantValCore.WF wf ci allowPrimitive state).mono fun _ _ _ h => by
+    obtain ⟨ci', hu, ht, hn', hci, hn, hp⟩ := h
+    exact ⟨ci', ⟨⟨hs, hu, ht⟩, hn'⟩, hci, hn, hp⟩
+
+/-- The body check proper, with the mvar/fvar check already discharged. `addDefinition` runs
+the two in the same `do` block for a safe definition but splits them for an unsafe one (the
+mvar/fvar check happens before the constant is added as an axiom), so they are verified
+separately.
+
+Stated against a single-level model (`VEnvAt`): a mutual block's bodies are checked in the
+temporary environment holding the whole block as axioms, which has no model at every level. -/
+theorem checkBodyCore.WF {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv)
+    (decl : Declaration) (levelParams : List Name) (type value : Expr)
+    (type' : VExpr) (hdeclType : TrExprS venv levelParams [] type type')
+    (hclosed : value.FVarsIn fun _ => False)
+    (state : TypeChecker.VState := {}) :
+    ((do
+      let valueType ← TypeChecker.checkType value
+      if !(← TypeChecker.isDefEq valueType type) then
+        throw <| Exception.declTypeMismatch env decl valueType) : TypeChecker.M Unit).WF
+      (.mk1 wf levelParams) state fun _ _ =>
+        ∃ value', TrExprS venv levelParams [] value value' ∧
+          venv.HasType levelParams.length [] value' type' := by
+  have hclosed' : value.FVarsIn
+      (· ∈ (TypeChecker.VContext.mk1 wf levelParams).vlctx.fvars) := by
+    simpa [TypeChecker.VContext.mk1] using hclosed
+  refine (TypeChecker.checkType.WF hclosed').bind
+    fun valueType _ _ ⟨value', valueType', _, hvalue, hvalueType, hhasType⟩ => ?_
+  refine (TypeChecker.isDefEq.WF hvalueType hdeclType).bind fun equal _ _ hequal => ?_
+  split
+  · exact .throw
+  · rename_i hnot
+    refine .pure ⟨value', hvalue, ?_⟩
+    have heq : equal = true := by cases equal <;> simp_all
+    exact hhasType.defeqU_r wf.tr.wf (by trivial) (hequal heq)
+
+theorem checkBody.WF {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv)
+    (decl : Declaration) (name : Name) (levelParams : List Name) (type value : Expr)
+    (type' : VExpr) (hdeclType : TrExprS venv levelParams [] type type')
+    (state : TypeChecker.VState := {}) :
+    ((do
+      Environment.checkNoMVarNoFVar env name value
+      let valueType ← TypeChecker.checkType value
+      if !(← TypeChecker.isDefEq valueType type) then
+        throw <| Exception.declTypeMismatch env decl valueType) : TypeChecker.M Unit).WF
+      (.mk1 wf levelParams) state fun _ _ =>
+        ∃ value', TrExprS venv levelParams [] value value' ∧
+          venv.HasType levelParams.length [] value' type' :=
+  (TypeChecker.M.WF.liftExcept
+    (checkNoMVarNoFVar.WF env name value)).bind fun _ _ _ hclosed =>
+  checkBodyCore.WF wf decl levelParams type value type' hdeclType hclosed _
+
+theorem checkTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : TheoremVal) :
+    ((do
+      checkConstantVal env v.toConstantVal
+      if !(← TypeChecker.isProp v.type) then
+        throw <| Exception.thmTypeIsNotProp env v.name v.type
+      Environment.checkNoMVarNoFVar env v.name v.value
+      let valueType ← TypeChecker.checkType v.value
+      if !(← TypeChecker.isDefEq valueType v.type) then
+        throw <| Exception.declTypeMismatch env (.thmDecl v) valueType) : TypeChecker.M Unit).WF
+      (.mk' wf .safe v.levelParams) {} fun _ _ =>
+        ∃ ci' : VDefVal, TrDefVal .safe (ves.venv .safe) (.thmInfo v) ci' ∧
+          ci'.WF (ves.venv .safe) ∧
+          (ves.venv .safe).HasType ci'.uvars [] ci'.type (.sort .zero) ∧
+          env.find? v.name = none ∧ Environment.primitives.contains v.name = false := by
+  refine (checkConstantVal.WF wf (.thmInfo v) false DefinitionSafety.le_rfl).bind
+    fun _ state _ ⟨ci', htr, hci, hn, hnonprim⟩ => ?_
+  refine (TypeChecker.isProp.WF htr.1.2.2).bind fun isProp state' _ hprop => ?_
+  split
+  · exact .throw
+  · rename_i hnot
+    have hisProp : isProp = true := by cases isProp <;> simp_all
+    refine .pureBind <| (checkBody.WF (wf.toVEnvAt .safe) (.thmDecl v) v.name v.levelParams v.type
+      v.value ci'.type htr.1.2.2 state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => ?_
+    let ci'' : VDefVal := { ci' with value := value' }
+    refine ⟨ci'', ⟨htr, hvalue⟩, ?_, ?_, hn, hnonprim rfl⟩
+    · change (ves.venv .safe).HasType ci'.uvars [] value' ci'.type
+      rw [← htr.1.2.1]
+      exact hvalueType
+    · change (ves.venv .safe).HasType ci'.uvars [] ci'.type (.sort .zero)
+      rw [← htr.1.2.1]
+      exact hprop hisProp
+
+theorem checkDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : DefinitionVal) :
+    ((do
+      checkConstantVal env v.toConstantVal (← Environment.checkPrimitiveDef v)
+      Environment.checkNoMVarNoFVar env v.name v.value
+      let valueType ← TypeChecker.checkType v.value
+      if !(← TypeChecker.isDefEq valueType v.type) then
+        throw <| Exception.declTypeMismatch env (.defnDecl v) valueType) : TypeChecker.M Unit).WF
+      (.mk' wf .safe v.levelParams) {} fun _ _ =>
+        ∃ allow : Bool, ∃ ci' : VDefVal, PrimitiveResult (ves.venv .safe) v allow ∧
+          v.levelParams.length = ci'.uvars ∧
+          TrExprS (ves.venv .safe) v.levelParams [] v.type ci'.type ∧
+          v.name = ci'.name ∧
+          TrExprS (ves.venv .safe) v.levelParams [] v.value ci'.value ∧
+          ci'.WF (ves.venv .safe) ∧ env.find? v.name = none ∧
+          (allow = false → Environment.primitives.contains v.name = false) := by
+  refine (checkPrimitiveDef.WF wf v).bind fun allow state _ hp => ?_
+  refine (checkConstantValCore.WF (safety := .safe) wf (.defnInfo v) allow state).bind
+    fun _ state' _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_
+  exact (checkBody.WF (wf.toVEnvAt .safe) (.defnDecl v) v.name v.levelParams v.type v.value
+    ci'.type ht state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by
+      let ci'' : VDefVal := { ci' with value := value' }
+      refine ⟨allow, ci'', hp, hu, ht, hname, hvalue, ?_, hfresh, hnonprim⟩
+      change (ves.venv .safe).HasType ci'.uvars [] value' ci'.type
+      rw [← hu]
+      exact hvalueType
+
+/-- Verify the complete opaque-declaration check. The body is checked, so it is packaged into
+the resulting `VDefVal`; `TrEnv'.opaque` consumes it. An opaque body still contributes no
+definitional equality -- that is `TrEnv'.opaque` adding no `addDefEq`, not the body going
+unrecorded. -/
+theorem checkOpaque.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : OpaqueVal) :
+    ((do
+      checkConstantVal env v.toConstantVal
+      Environment.checkNoMVarNoFVar env v.name v.value
+      let valueType ← TypeChecker.checkType v.value
+      if !(← TypeChecker.isDefEq valueType v.type) then
+        throw <| Exception.declTypeMismatch env (.opaqueDecl v) valueType) : TypeChecker.M Unit).WF
+      (.mk' wf .safe v.levelParams) {} fun _ _ =>
+      ∃ ci' : VDefVal,
+        v.levelParams.length = ci'.uvars ∧
+        TrExprS (ves.venv .safe) v.levelParams [] v.type ci'.type ∧
+        v.name = ci'.name ∧
+        TrExprS (ves.venv .safe) v.levelParams [] v.value ci'.value ∧
+        ci'.toVConstant.WF (ves.venv .safe) ∧
+        ci'.WF (ves.venv .safe) ∧ env.find? v.name = none ∧
+        Environment.primitives.contains v.name = false := by
+  refine (checkConstantValCore.WF (safety := .safe) wf (.opaqueInfo v) false).bind
+    fun _ state _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_
+  exact (checkBody.WF (wf.toVEnvAt .safe) (.opaqueDecl v) v.name v.levelParams v.type v.value
+    ci'.type ht state).mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by
+      let ci'' : VDefVal := { ci' with value := value' }
+      refine ⟨ci'', hu, ht, hname, hvalue, hci, ?_, hfresh, hnonprim rfl⟩
+      rwa [VDefVal.WF, ← hu]
diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean
index 305bde7d..0f3ca3bf 100644
--- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean
+++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean
@@ -892,13 +892,13 @@ def build :
       let viewDomainCheck ← checkConstructorAlignedExpr context viewDomain
       let parameterTypeCheck ← checkConstructorAlignedExpr context
         parameterType
-      match param with
+      match hparam : param with
       | .fvar fv =>
         if parameterPresent : (context.lctx.find? fv).isSome = true then
           let tail ← build tailTrace
-            (viewBody.instantiate1 (.fvar fv))
+            (viewBody.instantiate1 param)
           pure <| .parameter domainCheck viewDomainCheck parameterTypeCheck
-            rfl parameterPresent tailTrace tail
+            hparam parameterPresent tailTrace tail
         else
           throw <| .other
             "constructor parameter is absent from validation context"
@@ -1071,6 +1071,24 @@ theorem nonempty_of_check
       contradiction
   | ok alignment => exact ⟨alignment⟩
 
+/-- A successful alignment audit guarantees the retained builder returns its
+trace, so audit owners can replay `build` instead of choosing from
+`Nonempty`. -/
+theorem build_ok_of_check
+    {validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx
+      context seen constructors}
+    {candidates : AddInductive.CandidateList
+      AddInductive.CandidateConstructor constructors}
+    (success : check validationTrace candidates context = .ok ()) :
+    ∃ alignment, build validationTrace candidates = .ok alignment := by
+  unfold check at success
+  cases h : build validationTrace candidates with
+  | error error =>
+      rw [h] at success
+      change Except.error error = Except.ok () at success
+      contradiction
+  | ok alignment => exact ⟨alignment, rfl⟩
+
 end ConstructorCandidateAlignmentTrace
 
 /-- Source-ordered supplemental alignment audit for every exact constructor
@@ -1877,7 +1895,8 @@ theorem ConstructorUniverseTrace.nonempty_of_semanticGe
   · cases hstruct : levelStructGe resultLevel fieldLevel with
     | true => exact ⟨.structural hstruct⟩
     | false =>
-        exact ⟨.fallback hstruct (by simp [prop])⟩
+        exact ⟨.fallback hstruct
+          (by cases resultLevel <;> simp_all [Level.isZero, Level.isAlwaysZero])⟩
   · cases hstruct : levelStructGe resultLevel fieldLevel with
     | true => exact ⟨.structural hstruct⟩
     | false =>
@@ -1896,7 +1915,7 @@ theorem constructorUniverseSemanticGe_ofLevel
   rcases valid with structural | prop | ⟨_core, verified⟩
   · exact .inr (levelStructGe_ofLevel structural result_tr field_tr)
   · exact .inl (ofLevel_eq_zero_of_isZero prop result_tr)
-  · exact .inr (Level.geq'_wf verified result_tr field_tr)
+  · exact .inr (Level.geq'_wf result_tr field_tr verified)
 
 /-- Agreement between the ordinary and verified normalized comparisons opens
 the semantic fallback without weakening the ordinary acceptance boundary. -/
@@ -1959,7 +1978,11 @@ info: 'Lean4Lean.AddInductive.levelStructGe_ofLevel' depends on axioms: [propext
 /--
 info: 'Lean4Lean.AddInductive.constructorUniverseSemanticGe_ofLevel' depends on axioms: [propext,
  Classical.choice,
- Quot.sound]
+ Quot.sound,
+ Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
+ Std.TreeMap.all_eq_all_toList]
 -/
 #guard_msgs in
 #print axioms constructorUniverseSemanticGe_ofLevel
@@ -2408,7 +2431,7 @@ theorem nonempty_at
         arguments' := []
         result' := expected'
         arguments_tr := .nil
-        spine := rfl }⟩
+        spine := .nil }⟩
   | cons name domain body binderInfo argument arguments telescopeCheck
       step tail ih =>
       obtain ⟨domain', body', rfl, domainType, bodyType, domain_tr,
@@ -2473,7 +2496,7 @@ theorem nonempty_at
         arguments' := argumentRun.source' :: tailRun.arguments'
         result' := tailRun.result'
         arguments_tr := .cons argument_tr tailRun.arguments_tr
-        spine := ⟨domain', body', rfl, argumentType, tailRun.spine⟩ }⟩
+        spine := .cons argumentType tailRun.spine }⟩
 
 /-- Every successful operational spine trace has a verified interpretation;
 the initial strict endpoint is selected by the trace's own root `checkType`. -/
@@ -3937,6 +3960,32 @@ theorem ConstructorPreFamilyListTrace.nonempty_of_check
               exact ⟨⟨translationUnique, familyIndices, parameters,
                 constructors⟩⟩
 
+/-- A successful executable D3 gate guarantees the retained builder returns
+its trace, so gate owners can replay `buildConstructorPreFamilySafety`
+instead of choosing from `Nonempty`. -/
+theorem buildConstructorPreFamilySafety_ok_of_check
+    (success : checkConstructorPreFamilySafety stats familyView candidates
+      context = .ok ()) :
+    ∃ trace, buildConstructorPreFamilySafety stats familyView candidates
+      context = .ok trace := by
+  unfold checkConstructorPreFamilySafety at success
+  unfold buildConstructorPreFamilySafety
+  split
+  next translationUnique =>
+    simp [translationUnique] at success
+  next translationUnique =>
+    split
+    next error parameters =>
+      simp [translationUnique, parameters, Bind.bind, Except.bind] at success
+    next familyIndices parameters =>
+      cases hbuild : ConstructorPreFamilyListTrace.build stats 0 familyIndices
+          context candidates with
+      | error error =>
+          simp [translationUnique, parameters, hbuild,
+            Bind.bind, Except.bind] at success
+      | ok constructors =>
+          exact ⟨_, rfl⟩
+
 end AddInductive
 
 namespace TypeChecker
@@ -4331,8 +4380,10 @@ structure StagedNormalizationCandidatePostFamilyInput
 
 /-- Package a successful executable alignment audit into the staged D2 owner.
 The direct `alignment` field also permits proof-oriented clients to assemble
-the same indexed trace from already-retained checker observations. -/
-noncomputable def StagedNormalizationCandidatePostFamilyInput.ofRun
+the same indexed trace from already-retained checker observations.  The
+retained trace is computed by replaying the alignment builder; the audit
+premise only discharges its impossible error branch. -/
+def StagedNormalizationCandidatePostFamilyInput.ofRun
     {familyContext constructorContext : AddInductive.Context}
     {env : VEnv} {Us : List Name} {source : InductiveType}
     {candidate : AddInductive.NormalizationCandidate [source]}
@@ -4347,9 +4398,16 @@ noncomputable def StagedNormalizationCandidatePostFamilyInput.ofRun
     StagedNormalizationCandidatePostFamilyInput familyContext
       constructorContext env Us candidate rawDecl where
   universeInput := universeInput
-  alignment := Classical.choice <|
-    AddInductive.ConstructorCandidateAlignmentTrace.nonempty_of_check
-      alignmentRun
+  alignment :=
+    match h : AddInductive.ConstructorCandidateAlignmentTrace.build
+        universeInput.staged.constructorValidation.trace
+        candidate.families.singleton.constructors with
+    | .ok alignment => alignment
+    | .error _ =>
+        absurd
+          (AddInductive.ConstructorCandidateAlignmentTrace.build_ok_of_check
+            alignmentRun)
+          (by simp [h])
 
 /-- The exact output of D2: the established produced semantic hierarchy plus
 the actual post-family validation context, retained source/candidate
@@ -4454,8 +4512,10 @@ structure StagedNormalizationCandidatePreFamilyInput
 
 /-- Package a successful executable D3 gate into the staged owner. The gate
 itself, rather than a caller-supplied Theory premise, selects the retained
-parameter-instantiated family telescope and constructor traces. -/
-noncomputable def StagedNormalizationCandidatePreFamilyInput.ofRun
+parameter-instantiated family telescope and constructor traces.  The trace
+is computed by replaying the safety builder; the gate premise only
+discharges its impossible error branch. -/
+def StagedNormalizationCandidatePreFamilyInput.ofRun
     {familyContext constructorContext : AddInductive.Context}
     {env : VEnv} {Us : List Name} {source : InductiveType}
     {candidate : AddInductive.NormalizationCandidate [source]}
@@ -4471,8 +4531,17 @@ noncomputable def StagedNormalizationCandidatePreFamilyInput.ofRun
     StagedNormalizationCandidatePreFamilyInput familyContext
       constructorContext env Us candidate rawDecl where
   postFamilyInput := postFamilyInput
-  safety := Classical.choice <|
-    AddInductive.ConstructorPreFamilyListTrace.nonempty_of_check safetyRun
+  safety :=
+    match h : AddInductive.buildConstructorPreFamilySafety
+        postFamilyInput.universeInput.staged.family.validation.stats
+        candidate.families.singleton.familyType.type.view
+        candidate.families.singleton.constructors
+        candidate.families.singleton.familyType.type.trace.terminalContext with
+    | .ok safety => safety
+    | .error _ =>
+        absurd
+          (AddInductive.buildConstructorPreFamilySafety_ok_of_check safetyRun)
+          (by simp [h])
 
 /-- D3's produced meaning: D2's post-family semantics together with the exact
 verified pre-family context and source-ordered family-free replay selected by
@@ -5151,21 +5220,6 @@ theorem Closed.getAppArgsList
   | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE |
       letE => simp [Expr.getAppArgsList]
 
-theorem FVarsIn.getAppArgsList
-    (fvars : FVarsIn predicate expression) :
-    ∀ argument ∈ expression.getAppArgsList,
-      FVarsIn predicate argument := by
-  induction expression with
-  | app function argument functionIH argumentIH =>
-      intro candidate member
-      rw [Expr.getAppArgsList, expr_getAppArgsList_acc] at member
-      simp only [List.mem_append, List.mem_singleton] at member
-      rcases member with member | rfl
-      · exact functionIH fvars.1 candidate member
-      · exact fvars.2
-  | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE |
-      letE => simp [Expr.getAppArgsList]
-
 private theorem vexpr_appHead_appN (head : VExpr) (arguments : List VExpr) :
     VExpr.appHead (VExpr.appN head arguments) = VExpr.appHead head := by
   induction arguments generalizing head with
@@ -5264,29 +5318,6 @@ theorem forall₂_tr_mono
   | nil => exact .nil
   | cons head tail ih => exact .cons (head.mono add) ih
 
-/-- General verified context weakening for an application spine. -/
-theorem VEnv.SpineWF.weak'
-    {env : VEnv} (henv : env.Ordered)
-    {U : Nat} {lift : Lift} {context enlarged : List VExpr}
-    (extension : Ctx.Lift' lift context enlarged) :
-    ∀ {arguments : List VExpr} {source target : VExpr},
-      env.SpineWF U context source arguments target →
-      env.SpineWF U enlarged (source.lift' lift)
-        (arguments.map fun argument => argument.lift' lift)
-        (target.lift' lift) := by
-  intro arguments
-  induction arguments with
-  | nil =>
-      intro source target run
-      exact congrArg (fun expression => expression.lift' lift) run
-  | cons argument arguments ih =>
-      intro source target run
-      obtain ⟨domain, body, rfl, argumentType, tail⟩ := run
-      refine ⟨domain.lift' lift, body.lift' lift.cons, rfl,
-        argumentType.weak' henv extension, ?_⟩
-      have weakened := ih tail
-      rwa [VExpr.lift'_inst_hi] at weakened
-
 theorem isValidIndAppIdx_shape
     {stats : AddInductive.InductiveStats} {source : Expr}
     {familyIdx : Nat}
@@ -5457,74 +5488,6 @@ theorem TrExprS.forall₂_weakFV_inv_defeq
       exact ⟨headBase :: tailBase, .cons headBaseRun tailBaseRuns, by
         simp only [List.map_cons, tailEq]⟩
 
-/-- Invert weakening of every component of an application-spine judgment when
-the enlarged context is well formed. -/
-theorem VEnv.SpineWF.weakN_inv
-    {env : VEnv} {U n k : Nat} {context enlarged : List VExpr}
-    (henv : VEnv.WF env) (enlargedWF : OnCtx enlarged (env.IsType U))
-    (extension : Ctx.LiftN n k context enlarged) :
-    ∀ {arguments : List VExpr} {source target : VExpr},
-      env.SpineWF U enlarged (source.liftN n k)
-        (arguments.map fun argument => argument.liftN n k)
-        (target.liftN n k) →
-      env.SpineWF U context source arguments target := by
-  intro arguments
-  induction arguments with
-  | nil =>
-      intro source target run
-      exact VExpr.liftN_inj.1 run
-  | cons argument arguments ih =>
-      intro source target run
-      obtain ⟨domain', body', sourceEq, argumentType, tail⟩ := run
-      cases source with
-      | bvar index => cases sourceEq
-      | sort level => cases sourceEq
-      | const name levels => cases sourceEq
-      | app fn argument => cases sourceEq
-      | lam domain body => cases sourceEq
-      | forallE domain body =>
-        injection sourceEq with domainEq bodyEq
-        subst domain'
-        subst body'
-        refine ⟨domain, body, rfl,
-          (HasType.weakN_iff henv enlargedWF extension).1 argumentType, ?_⟩
-        rw [← VExpr.liftN_inst_hi] at tail
-        exact ih tail
-
-/-- Invert a general verified context lift componentwise across an
-application-spine judgment. -/
-theorem VEnv.SpineWF.weak'_inv
-    {env : VEnv} {U : Nat} {lift : Lift} {context enlarged : List VExpr}
-    (henv : VEnv.WF env) (enlargedWF : OnCtx enlarged (env.IsType U))
-    (extension : Ctx.Lift' lift context enlarged) :
-    ∀ {arguments : List VExpr} {source target : VExpr},
-      env.SpineWF U enlarged (source.lift' lift)
-        (arguments.map fun argument => argument.lift' lift)
-        (target.lift' lift) →
-      env.SpineWF U context source arguments target := by
-  intro arguments
-  induction arguments with
-  | nil =>
-      intro source target run
-      exact VExpr.lift'_inj.1 run
-  | cons argument arguments ih =>
-      intro source target run
-      obtain ⟨domain', body', sourceEq, argumentType, tail⟩ := run
-      cases source with
-      | bvar index => cases sourceEq
-      | sort level => cases sourceEq
-      | const name levels => cases sourceEq
-      | app fn argument => cases sourceEq
-      | lam domain body => cases sourceEq
-      | forallE domain body =>
-        injection sourceEq with domainEq bodyEq
-        subst domain'
-        subst body'
-        refine ⟨domain, body, rfl,
-          (HasType.weak'_iff henv enlargedWF extension).1 argumentType, ?_⟩
-        rw [← VExpr.lift'_inst_hi] at tail
-        exact ih tail
-
 theorem ConstructorPreFamilyIndexSpineSemanticRun.expected_eq_of_family_lift
     {env : VEnv} {Us : List Name} {context : AddInductive.Context}
     {contextRun : AddInductive.ConstructorContextRun env Us context}
@@ -6496,57 +6459,6 @@ private theorem forallN_hasConst_of_terminal
       simp only [VExpr.forallN, VExpr.hasConst, Bool.or_eq_true]
       exact .inr ih
 
-/-- Context lifting changes only bound-variable indices and therefore
-preserves the set of constants occurring in a Theory expression. -/
-private theorem VExpr.hasConst_lift' (expression : VExpr) (lift : Lift)
-    (name : Name) :
-    (expression.lift' lift).hasConst name = expression.hasConst name := by
-  induction expression generalizing lift <;>
-    simp [VExpr.hasConst, *]
-
-/-- A typed Theory expression cannot mention a constant absent from its
-environment. -/
-theorem VEnv.HasType.hasConst_false_of_absent
-    {env : VEnv} {U : Nat} {context : List VExpr}
-    {familyName : Name} {expression type : VExpr}
-    (henv : env.Ordered) (contextWF : OnCtx context (env.IsType U))
-    (absent : env.constants familyName = none)
-    (typed : env.HasType U context expression type) :
-    expression.hasConst familyName = false := by
-  induction expression generalizing context type with
-  | bvar | sort => rfl
-  | const name levels =>
-      by_cases equality : name = familyName
-      · subst name
-        obtain ⟨constant, present, levelWF, arity⟩ :=
-          typed.const_inv henv contextWF
-        rw [absent] at present
-        contradiction
-      · simpa [VExpr.hasConst, equality]
-  | app function argument functionIH argumentIH =>
-      obtain ⟨domain, body, functionType, argumentType⟩ :=
-        typed.app_inv henv contextWF
-      simp only [VExpr.hasConst, functionIH contextWF functionType,
-        argumentIH contextWF argumentType, Bool.false_or]
-  | lam domain body domainIH bodyIH =>
-      obtain ⟨domainType, bodyWF⟩ := typed.lam_inv henv contextWF
-      obtain ⟨domainLevel, domainHasType⟩ := domainType
-      obtain ⟨bodyType, bodyHasType⟩ := bodyWF
-      have nextContextWF : OnCtx (domain :: context) (env.IsType U) := by
-        change OnCtx context (env.IsType U) ∧ env.IsType U context domain
-        exact ⟨contextWF, ⟨domainLevel, domainHasType⟩⟩
-      simp only [VExpr.hasConst, domainIH contextWF domainHasType,
-        bodyIH nextContextWF bodyHasType, Bool.false_or]
-  | forallE domain body domainIH bodyIH =>
-      obtain ⟨domainType, bodyType⟩ := typed.forallE_inv henv
-      obtain ⟨domainLevel, domainHasType⟩ := domainType
-      obtain ⟨bodyLevel, bodyHasType⟩ := bodyType
-      have nextContextWF : OnCtx (domain :: context) (env.IsType U) := by
-        change OnCtx context (env.IsType U) ∧ env.IsType U context domain
-        exact ⟨contextWF, ⟨domainLevel, domainHasType⟩⟩
-      simp only [VExpr.hasConst, domainIH contextWF domainHasType,
-        bodyIH nextContextWF bodyHasType, Bool.false_or]
-
 theorem recArg?_eq_none_of_hasConst_false
     (free : field.hasConst familyName = false) :
     VInductDecl.recArg? U familyName np ni fieldIndex field = none := by
@@ -7236,9 +7148,7 @@ theorem constructorFields_exactAnalyzer
                     have nextWF := nextD3ContextRun.candidate.context.Δwf
                     rw [nextD3ContextRun.venv_eq,
                       nextD3ContextRun.lparams_eq] at nextWF
-                    simpa only [nextD3ContextRun,
-                      AddInductive.ConstructorContextRun.pushLocalDecl,
-                      CandidateContextRun.pushLocalDecl_vlctx] using nextWF
+                    exact nextWF
                   have postViewTr : TrExprS typeEnv Us
                       d2ContextRun.candidate.context.vlctx domain
                       viewDomainRun₂.source' := by
@@ -7349,10 +7259,7 @@ theorem constructorFields_exactAnalyzer
                           (consumeTypeAnnotations domain).fvarsList),
                         .vlam (commonDomain.lift' viewLift)) :: d3ViewContext)
                       (.consN fullLift 1) (.consN viewLift 1) := by
-                    simpa only [vlctxCons, nextD3ContextRun,
-                      AddInductive.ConstructorContextRun.pushLocalDecl,
-                      CandidateContextRun.pushLocalDecl_vlctx] using
-                      nextD3State
+                    exact nextD3State
                   have nextAnalyzerState' : AnalyzerPostContextState
                       typeEnv Us
                       ((some (context.freshFVarId,
@@ -8577,6 +8484,102 @@ theorem StagedNormalizationCandidatePreFamilyInput.normalization_eq
     rw [familyEq]
   exact Normalization.eq_of_view_eq viewDeclEq
 
+/-- Choice-free constructor-root interpretation: the semantic root's view is
+computed by the deterministic translator under the constructor's strict-view
+uniqueness certificate. -/
+def CandidateConstructorSemanticInput.semanticOfUnique
+    {env : VEnv} {Us : List Name} {source : Constructor}
+    {candidate : AddInductive.CandidateConstructor source} {raw : VConstVal}
+    (input : CandidateConstructorSemanticInput env Us candidate raw)
+    (unique : TypeChecker.CandidateExprTraceViewIsUnique
+      candidate.type.trace) :
+    CandidateConstructorSemanticRun env Us candidate raw where
+  name_eq := input.name_eq
+  uvars_eq := input.uvars_eq
+  type := input.type.semanticOfUnique unique
+
+/-- Choice-free source-ordered interpretation of a complete constructor list
+under its source-ordered strict-view certificate. -/
+def CandidateConstructorSemanticListInput.semanticOfUnique
+    {env : VEnv} {Us : List Name} :
+    {sources : List Constructor} →
+    {candidates : AddInductive.CandidateList
+      AddInductive.CandidateConstructor sources} →
+    {raws : List VConstVal} →
+    CandidateConstructorSemanticListInput env Us candidates raws →
+    candidates.ViewTranslationUnique →
+    CandidateConstructorSemanticListRun env Us candidates raws
+  | _, _, _, .nil, _ => .nil
+  | _, _, _, .cons head tail, unique =>
+    .cons (head.semanticOfUnique unique.1) (tail.semanticOfUnique unique.2)
+
+/-- Choice-free family interpretation: the family type and every
+post-insertion constructor view are computed by the deterministic
+translator. -/
+def CandidateFamilySemanticInput.semanticOfUnique
+    {env : VEnv} {Us : List Name} {source : InductiveType}
+    {candidate : AddInductive.CandidateFamily source} {raw : VInductiveType}
+    (input : CandidateFamilySemanticInput env Us candidate raw)
+    (uniqueType : TypeChecker.CandidateExprTraceViewIsUnique
+      candidate.familyType.type.trace)
+    (uniqueCtors : candidate.constructors.ViewTranslationUnique) :
+    CandidateFamilySemanticRun env Us candidate raw where
+  name_eq := input.name_eq
+  uvars_eq := input.uvars_eq
+  type := input.type.semanticOfUnique uniqueType
+  typeEnv := input.typeEnv
+  addType := input.addType
+  constructors := input.constructors.semanticOfUnique uniqueCtors
+
+/-- Choice-free singleton semantic hierarchy: every normalized Theory view
+in the family and constructor list is computed by the deterministic
+translator, with `Nonempty` interpretation transferred onto the computed
+values. -/
+def NormalizationCandidateSemanticInput.semanticOfUnique
+    {env : VEnv} {Us : List Name} {source : InductiveType}
+    {candidate : AddInductive.NormalizationCandidate [source]}
+    {rawDecl : VInductDecl}
+    (input : NormalizationCandidateSemanticInput env Us candidate rawDecl)
+    (uniqueType : TypeChecker.CandidateExprTraceViewIsUnique
+      candidate.families.singleton.familyType.type.trace)
+    (uniqueCtors :
+      candidate.families.singleton.constructors.ViewTranslationUnique) :
+    NormalizationCandidateSemanticRun env Us candidate rawDecl where
+  raw := input.raw
+  raw_types_eq := input.raw_types_eq
+  uvars_eq := input.uvars_eq
+  family := input.family.semanticOfUnique uniqueType uniqueCtors
+
+/-- The executable D3 gate's uniqueness Bool supplies the family strict-view
+certificate consumed by the choice-free semantic assembly. -/
+theorem StagedNormalizationCandidatePreFamilyInput.familyViewUnique
+    {familyContext constructorContext : AddInductive.Context}
+    {env : VEnv} {Us : List Name} {source : InductiveType}
+    {candidate : AddInductive.NormalizationCandidate [source]}
+    {rawDecl : VInductDecl}
+    (input : StagedNormalizationCandidatePreFamilyInput familyContext
+      constructorContext env Us candidate rawDecl) :
+    TypeChecker.CandidateExprTraceViewIsUnique
+      candidate.families.singleton.familyType.type.trace := by
+  have h := input.safety.translationUnique
+  simp only [Bool.and_eq_true] at h
+  exact AddInductive.CandidateExprTrace.viewTranslationUnique_sound _
+    ((AddInductive.CandidateExprTrace.viewTranslationUnique_eq _).trans h.1)
+
+/-- The executable D3 gate's uniqueness Bool likewise supplies the
+constructor-list strict-view certificate. -/
+theorem StagedNormalizationCandidatePreFamilyInput.constructorViewsUnique
+    {familyContext constructorContext : AddInductive.Context}
+    {env : VEnv} {Us : List Name} {source : InductiveType}
+    {candidate : AddInductive.NormalizationCandidate [source]}
+    {rawDecl : VInductDecl}
+    (input : StagedNormalizationCandidatePreFamilyInput familyContext
+      constructorContext env Us candidate rawDecl) :
+    candidate.families.singleton.constructors.ViewTranslationUnique := by
+  have h := input.safety.translationUnique
+  simp only [Bool.and_eq_true] at h
+  exact AddInductive.CandidateList.viewTranslationUnique_sound _ h.2
+
 /-- Exact, source-indexed refinement of the public producer package.
 
 The public `ProducedGenerationCandidatePackage` deliberately erases its
@@ -8613,6 +8616,41 @@ def ExactProducedGenerationCandidatePackage.package
   exact.semantic.producedPackage context source.nparams numNested isUnsafe
     producedCandidate.produced
 
+/-- Close one strengthened singleton producer choice-free.  The semantic
+hierarchy is computed by the deterministic translator under the executable
+D3 strict-view gate carried by the staged owner, so the retained package is
+data rather than a `Classical.choice` selection from `Nonempty`. -/
+def ProducedGenerationShapeCandidate.exactProducedPackage
+    {familyContext constructorContext : AddInductive.Context}
+    {env : VEnv} {Us : List Name}
+    {kernelSource : InductiveType} {source : VInductDecl}
+    {raw : VInductiveType} {numNested : Nat} {isUnsafe : Bool}
+    {context : AddInductive.Context}
+    (producedCandidate : ProducedGenerationShapeCandidate source raw
+      kernelSource numNested isUnsafe context)
+    (input : StagedNormalizationCandidatePreFamilyInput familyContext
+      constructorContext env Us producedCandidate.candidate source)
+    (rawOwnerEq : raw =
+      input.postFamilyInput.universeInput.staged.raw)
+    (generation : GenerationChecked source)
+    (analysis : ∀ normalization : NormalizationCandidateSemanticRun env Us
+        producedCandidate.candidate source,
+      normalization.root.normalization.generation? = some generation) :
+    ExactProducedGenerationCandidatePackage env Us
+      producedCandidate generation :=
+  let normalization :=
+    input.postFamilyInput.universeInput.staged.semanticInput.semanticOfUnique
+      input.familyViewUnique input.constructorViewsUnique
+  { normalization := normalization
+    raw_eq := rawOwnerEq
+    semantic := GenerationCandidateSemanticRun.ofGenerationShape input
+      normalization generation (analysis normalization)
+      (by
+        have hraw : normalization.raw =
+            input.postFamilyInput.universeInput.staged.raw := rfl
+        simpa only [NormalizationCandidateSemanticRun.generationShape,
+          rawOwnerEq, hraw] using producedCandidate.shape) }
+
 /-- Close one strengthened singleton producer from the staged D1--D4 owner
 without choosing a semantic hierarchy at the API boundary, while retaining
 the exact dependent source and generation indices needed by consumers. -/
@@ -8707,9 +8745,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.checkedW
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8740,9 +8781,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.viewDecl
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8773,9 +8817,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8806,9 +8853,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.producedPackageOf
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8839,9 +8889,12 @@ info: 'Lean4Lean.VInductDecl.ProducedGenerationShapeCandidate.producedPackage' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8872,9 +8925,12 @@ info: 'Lean4Lean.VInductDecl.ProducedGenerationShapeCandidate.exactProducedPacka
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8905,9 +8961,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.exists'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8938,9 +8997,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePostFamilyInput.exists'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -8952,7 +9014,6 @@ new universe bridge itself remains separately guarded above; staging does not
 hide the transitional dependencies already present in the semantic owner. -/
 /--
 info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.semanticValidation' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -8961,7 +9022,6 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.semanticV
 
 /--
 info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.universeSemantics' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -8992,9 +9052,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.exists' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean
index 9e096ec3..43cafde0 100644
--- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean
+++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean
@@ -57,7 +57,7 @@ def l4l05EmptyVEnvs : VEnvs where
   venv _ := VEnv.empty
 
 theorem l4l05EmptyHasPrimitives : VEnv.HasPrimitives VEnv.empty := by
-  apply TypeChecker.VEnv.HasPrimitives.of_avoids
+  apply VEnv.HasPrimitives.of_avoids
   intro name membership
   rfl
 
@@ -79,6 +79,16 @@ theorem cvmEmptyVEnvsWF :
   hasPrimitives := l4l05EmptyHasPrimitives
   safePrimitives := cvmEmptySafePrimitives
   mono := fun _ => .rfl
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name info h
+    change ({} : ConstMap).find?' name = some (.ctorInfo info) at h
+    rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h
+    simp [SMap.find?] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name info h
+    change ({} : ConstMap).find?' name = some (.ctorInfo info) at h
+    rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h
+    simp [SMap.find?] at h
 
 theorem prbEmptySafePrimitives :
     propRecursiveBoundaryContext.env.find? name = some info →
@@ -98,6 +108,16 @@ theorem prbEmptyVEnvsWF :
   hasPrimitives := l4l05EmptyHasPrimitives
   safePrimitives := prbEmptySafePrimitives
   mono := fun _ => .rfl
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name info h
+    change ({} : ConstMap).find?' name = some (.ctorInfo info) at h
+    rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h
+    simp [SMap.find?] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name info h
+    change ({} : ConstMap).find?' name = some (.ctorInfo info) at h
+    rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h
+    simp [SMap.find?] at h
 
 def cvmExecutionResult :=
   AddInductive.buildNormalizationCandidateExecution 2
@@ -544,6 +564,24 @@ def cvmDeclaredInfo : ConstantInfo :=
     0 false
     cvmCandidate.families.singleton.familyType.type.trace.terminalContext
 
+theorem cvmDeclaredInfo_isRec :
+    (AddInductive.singletonDeclaredInfo
+      cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType
+      0 false
+      cvmCandidate.families.singleton.familyType.type.trace.terminalContext).isRec =
+      true := by
+  simp only [AddInductive.singletonDeclaredInfo]
+  rw [cvmFamilyValidationRun.stats_eq]
+  simp [cvmFamilyValidationRun,
+    AddInductive.CandidateExprTrace.singletonCandidateInductiveStats,
+    AddInductive.isRec, AddInductive.isRec.loop,
+    AddInductive.hasIndOcc,
+    constructorValidityMatrixKernelType,
+    constructorValidityMatrixKernelCtor,
+    constructorValidityMatrixInfo, constructorValidityMatrixMkInfo,
+    ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal,
+    Expr.constName!]
+
 theorem cvmFamilyNames_eq :
     constructorValidityMatrixKernelType.name =
       constructorValidityMatrixType.name := by
@@ -563,6 +601,66 @@ theorem cvmFamilyMap_add :
       cvmCandidate.families.singleton.familyType.type.trace.terminalContext
       cvmExecution.familyEnv cvmStatsNindices_eq h
 
+theorem cvmConstructorContext_noProjectionReady (name : Name) :
+    cvmConstructorContext.env.isProjectionReadyStructure name = false := by
+  have hConstants :
+      cvmConstructorContext.env.constants =
+        ({} : ConstMap).insert constructorValidityMatrixType.name
+          cvmDeclaredInfo := by
+    simp only [cvmConstructorContext]
+    rw [cvmFamilyMap_add, cvmTerminalEnv_eq]
+    rfl
+  have hMap :
+      (({} : ConstMap).insert constructorValidityMatrixType.name
+        cvmDeclaredInfo).WF :=
+    SMap.WF.empty.insert _ _ (by simp [SMap.find?])
+  by_cases hName : constructorValidityMatrixType.name = name
+  · subst name
+    apply Kernel.Environment.isProjectionReadyStructure_false_of_no_ctorInfo
+      (info := AddInductive.singletonDeclaredInfo
+        cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType
+        0 false
+        cvmCandidate.families.singleton.familyType.type.trace.terminalContext)
+    · rw [hConstants, hMap.find?'_eq_find?,
+        SMap.WF.find?_insert
+          (s := ({} : ConstMap)) SMap.WF.empty]
+      simp [cvmDeclaredInfo]
+    · intro ctor ctorInfo hctor
+      rw [hConstants, hMap.find?'_eq_find?,
+        SMap.WF.find?_insert
+          (s := ({} : ConstMap)) SMap.WF.empty] at hctor
+      split at hctor
+      · cases hctor
+      · simp [SMap.find?] at hctor
+  · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found
+    rw [hConstants, hMap.find?'_eq_find?,
+      SMap.WF.find?_insert
+        (s := ({} : ConstMap)) SMap.WF.empty]
+    simp [hName, SMap.find?]
+
+theorem cvmConstructorContext_noCtorInfo (name : Name)
+    (info : ConstructorVal) :
+    cvmConstructorContext.env.find? name ≠ some (.ctorInfo info) := by
+  intro h
+  have hConstants :
+      cvmConstructorContext.env.constants =
+        ({} : ConstMap).insert constructorValidityMatrixType.name
+          cvmDeclaredInfo := by
+    simp only [cvmConstructorContext]
+    rw [cvmFamilyMap_add, cvmTerminalEnv_eq]
+    rfl
+  have hMap :
+      (({} : ConstMap).insert constructorValidityMatrixType.name
+        cvmDeclaredInfo).WF :=
+    SMap.WF.empty.insert _ _ (by simp [SMap.find?])
+  change cvmConstructorContext.env.constants.find?' name =
+    some (.ctorInfo info) at h
+  rw [hConstants, hMap.find?'_eq_find?,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h
+  split at h
+  · cases h
+  · simp [SMap.find?] at h
+
 def cvmTypeEnv : VEnv :=
   (VEnv.empty.addConst constructorValidityMatrixType.name
     constructorValidityMatrixType.toVConstant).get!
@@ -626,6 +724,10 @@ def cvmFamilyStage :
   validation := cvmFamilyValidationRun
   typeEnv := cvmTypeEnv
   addInduct := cvmAddType
+  projectionReady := ProjectionReady.of_no_ctorInfo
+    cvmConstructorContext_noCtorInfo
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo
+    cvmConstructorContext_noCtorInfo
   family_lctx_eq := rfl
   constructorContext_eq := rfl
   quotInit_eq := by
@@ -1789,6 +1891,60 @@ theorem prbTerminalEnv_eq :
       congrArg AddInductive.Context.env prbFamilyCandidateContext_eq
     _ = propRecursiveBoundaryContext.env := rfl
 
+theorem prbConstructorContext_noProjectionReady (name : Name) :
+    prbConstructorContext.env.isProjectionReadyStructure name = false := by
+  have hConstants :
+      prbConstructorContext.env.constants =
+        ({} : ConstMap).insert propRecursiveBoundaryType.name
+          prbDeclaredInfo := by
+    simp only [prbConstructorContext]
+    rw [prbFamilyMap_add, prbTerminalEnv_eq]
+    rfl
+  have hMap :
+      (({} : ConstMap).insert propRecursiveBoundaryType.name
+        prbDeclaredInfo).WF :=
+    SMap.WF.empty.insert _ _ (by simp [SMap.find?])
+  by_cases hName : propRecursiveBoundaryType.name = name
+  · subst name
+    apply Kernel.Environment.isProjectionReadyStructure_false_of_numIndices_ne
+      (info := AddInductive.singletonDeclaredInfo
+        prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType
+        0 false
+        prbCandidate.families.singleton.familyType.type.trace.terminalContext)
+    · rw [hConstants, hMap.find?'_eq_find?,
+        SMap.WF.find?_insert
+          (s := ({} : ConstMap)) SMap.WF.empty]
+      simp [prbDeclaredInfo]
+    · simp [AddInductive.singletonDeclaredInfo]
+  · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found
+    rw [hConstants, hMap.find?'_eq_find?,
+      SMap.WF.find?_insert
+        (s := ({} : ConstMap)) SMap.WF.empty]
+    simp [hName, SMap.find?]
+
+theorem prbConstructorContext_noCtorInfo (name : Name)
+    (info : ConstructorVal) :
+    prbConstructorContext.env.find? name ≠ some (.ctorInfo info) := by
+  intro h
+  have hConstants :
+      prbConstructorContext.env.constants =
+        ({} : ConstMap).insert propRecursiveBoundaryType.name
+          prbDeclaredInfo := by
+    simp only [prbConstructorContext]
+    rw [prbFamilyMap_add, prbTerminalEnv_eq]
+    rfl
+  have hMap :
+      (({} : ConstMap).insert propRecursiveBoundaryType.name
+        prbDeclaredInfo).WF :=
+    SMap.WF.empty.insert _ _ (by simp [SMap.find?])
+  change prbConstructorContext.env.constants.find?' name =
+    some (.ctorInfo info) at h
+  rw [hConstants, hMap.find?'_eq_find?,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h
+  split at h
+  · cases h
+  · simp [SMap.find?] at h
+
 theorem prbDeclaredInfo_tr :
     TrConstVal .safe VEnv.empty prbDeclaredInfo
       propRecursiveBoundaryType.toVConstVal := by
@@ -1842,6 +1998,10 @@ def prbFamilyStage :
   validation := prbFamilyValidationRun
   typeEnv := prbTypeEnv
   addInduct := prbAddType
+  projectionReady := ProjectionReady.of_no_ctorInfo
+    prbConstructorContext_noCtorInfo
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo
+    prbConstructorContext_noCtorInfo
   family_lctx_eq := rfl
   constructorContext_eq := rfl
   quotInit_eq := by
@@ -3628,14 +3788,14 @@ private theorem prbCandidateWhnfResult_eq
   rw [self] at other
   exact (Except.ok.inj other).symm
 
-noncomputable def prbConstructorValidation :
+def prbConstructorValidation :
     AddInductive.ConstructorValidationRun propRecursiveBoundaryKernelType
       prbFamilyValidationRun.stats false
       prbConstructorValidationContext :=
   AddInductive.ConstructorValidationRun.of_run (by
     simpa [prbConstructorValidationContext] using prbCheckConstructorsRun)
 
-noncomputable def prbStagedUniverseInput :
+def prbStagedUniverseInput :
     VInductDecl.StagedNormalizationCandidateUniverseInput
       prbFamilyContext prbConstructorContext VEnv.empty [`u]
       prbCandidate propRecursiveBoundaryDecl where
@@ -3712,7 +3872,7 @@ private def prbValidationNextDomainAnnotations :
   ⟨AddInductive.candidateIsDefEqRefl prbValidationAContext
     prbValidationNextDomain⟩
 
-private noncomputable def prbValidationAlphaPositivityAlignment
+private def prbValidationAlphaPositivityAlignment
     (trace : AddInductive.ConstructorPositivityModeTrace
       prbStagedUniverseInput.staged.family.validation.stats false
       propRecursiveBoundaryKernelCtor.name 1 prbValidationRootContext
@@ -3766,7 +3926,7 @@ private def prbTransportPositivityAlignment
   subst source'
   exact alignment
 
-private noncomputable def prbValidationNextPositivityAlignment
+private def prbValidationNextPositivityAlignment
     (trace : AddInductive.ConstructorPositivityModeTrace
       prbStagedUniverseInput.staged.family.validation.stats false
       propRecursiveBoundaryKernelCtor.name 2 prbValidationAContext
@@ -3940,7 +4100,7 @@ private def prbTransportViewAlignmentIndexed
 
 set_option pp.universes false in
 set_option pp.all false in
-noncomputable def prbStagedPostFamilyInput :
+def prbStagedPostFamilyInput :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput
       prbFamilyContext prbConstructorContext VEnv.empty [`u]
       prbCandidate propRecursiveBoundaryDecl where
@@ -5457,7 +5617,7 @@ theorem prbSafetyRun :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput.ofRun] using
     prbSafetyRunDirect
 
-noncomputable def prbStagedPreFamilyInput :
+def prbStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       prbFamilyContext prbConstructorContext VEnv.empty [`u]
       prbCandidate propRecursiveBoundaryDecl :=
@@ -6716,7 +6876,7 @@ theorem cvmCtorTerminalValidationShapeTest :
     AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId,
     Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1']
 
-noncomputable def cvmConstructorValidationTest :
+def cvmConstructorValidationTest :
     AddInductive.ConstructorValidationRun
       constructorValidityMatrixKernelType cvmFamilyValidationRun.stats false
       cvmValidationRootContextTest :=
@@ -8402,7 +8562,7 @@ def cvmValidationFunctionPosBodyCheckedTest :
       rw [cvmValidationPFindInFunctionPosTest]
       rfl) cvmValidationFunctionPosBodyCheckTest
 
-noncomputable def cvmStagedUniverseInputTest :
+def cvmStagedUniverseInputTest :
     VInductDecl.StagedNormalizationCandidateUniverseInput
       cvmFamilyContext cvmConstructorContext VEnv.empty [`u]
       cvmCandidate constructorValidityMatrixDecl where
@@ -8673,7 +8833,7 @@ def cvmTransportPositivityFuelAlignmentTest
   subst fuel'
   exact alignment
 
-noncomputable def cvmAbsentPositivityAlignmentCoreTest
+def cvmAbsentPositivityAlignmentCoreTest
     (self : AddInductive.CandidateWhnfStep.Valid
       ⟨context, source, source⟩)
     (notForall : source.isForall = false)
@@ -8701,7 +8861,7 @@ noncomputable def cvmAbsentPositivityAlignmentCoreTest
       rw [noOccurrence] at occurs
       contradiction
 
-noncomputable def cvmTargetPositivityAlignmentCoreTest
+def cvmTargetPositivityAlignmentCoreTest
     (self : AddInductive.CandidateWhnfStep.Valid
       ⟨context, source, source⟩)
     (notForall : source.isForall = false)
@@ -8729,7 +8889,7 @@ noncomputable def cvmTargetPositivityAlignmentCoreTest
       subst result
       exact .target checked
 
-noncomputable def cvmAbsentPositivityModeAlignmentTest
+def cvmAbsentPositivityModeAlignmentTest
     (self : AddInductive.CandidateWhnfStep.Valid
       ⟨context, source, source⟩)
     (notForall : source.isForall = false)
@@ -8750,7 +8910,7 @@ noncomputable def cvmAbsentPositivityModeAlignmentTest
       exact cvmTransportPositivityFuelAlignmentTest
         inductiveFuel positivityTrace normalizedAlignment
 
-noncomputable def cvmTargetPositivityModeAlignmentTest
+def cvmTargetPositivityModeAlignmentTest
     (self : AddInductive.CandidateWhnfStep.Valid
       ⟨context, source, source⟩)
     (notForall : source.isForall = false)
@@ -8771,7 +8931,7 @@ noncomputable def cvmTargetPositivityModeAlignmentTest
       exact cvmTransportPositivityFuelAlignmentTest
         inductiveFuel positivityTrace normalizedAlignment
 
-noncomputable def cvmValidationXPositivityAlignmentTest
+def cvmValidationXPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 2
@@ -8781,7 +8941,7 @@ noncomputable def cvmValidationXPositivityAlignmentTest
     (by rw [cvmCtorXDomainValidationShapeTest]; rfl)
     cvmValidationXHasNoIndOccTest cvmValidationXCheckedTest (by rfl) trace
 
-noncomputable def cvmValidationProofPositivityAlignmentTest
+def cvmValidationProofPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 3
@@ -8792,7 +8952,7 @@ noncomputable def cvmValidationProofPositivityAlignmentTest
     cvmValidationProofHasNoIndOccTest cvmValidationProofCheckedTest
     (by rfl) trace
 
-noncomputable def cvmValidationDirectPositivityAlignmentTest
+def cvmValidationDirectPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 4
@@ -8803,7 +8963,7 @@ noncomputable def cvmValidationDirectPositivityAlignmentTest
     cvmValidationDirectHasIndOccTest cvmValidationDirectCheckedTest
     (by rfl) trace
 
-noncomputable def cvmValidationLaterPositivityAlignmentTest
+def cvmValidationLaterPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 6
@@ -8814,7 +8974,7 @@ noncomputable def cvmValidationLaterPositivityAlignmentTest
     cvmValidationLaterHasNoIndOccTest cvmValidationLaterCheckedTest
     (by rfl) trace
 
-noncomputable def cvmValidationLaterProofPositivityAlignmentTest
+def cvmValidationLaterProofPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 7
@@ -8850,7 +9010,7 @@ def cvmTransportPositivityAlignmentTest
   subst source'
   exact alignment
 
-noncomputable def cvmValidationFunctionPositivityAlignmentTest
+def cvmValidationFunctionPositivityAlignmentTest
     (trace : AddInductive.ConstructorPositivityModeTrace
       cvmStagedUniverseInputTest.staged.family.validation.stats false
       constructorValidityMatrixKernelCtor.name 5
@@ -9061,7 +9221,7 @@ def cvmTransportViewAlignmentIndexedTest
 
 set_option pp.universes false in
 set_option pp.all false in
-noncomputable def cvmStagedPostFamilyInputTest :
+def cvmStagedPostFamilyInputTest :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput
       cvmFamilyContext cvmConstructorContext VEnv.empty [`u]
       cvmCandidate constructorValidityMatrixDecl where
@@ -11234,7 +11394,7 @@ theorem cvmSafetyRunTest :
         .ok () := by
   simpa [cvmStagedPostFamilyInputTest] using cvmSafetyRunDirectTest
 
-noncomputable def cvmStagedPreFamilyInputTest :
+def cvmStagedPreFamilyInputTest :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       cvmFamilyContext cvmConstructorContext VEnv.empty [`u]
       cvmCandidate constructorValidityMatrixDecl :=
@@ -11254,11 +11414,11 @@ theorem cvmUniverseRun :
     rw [cvmConstructorValidationContextTest_root]
     exact cvmUniverseRunTest
 
-noncomputable def cvmConstructorValidation := cvmConstructorValidationTest
+def cvmConstructorValidation := cvmConstructorValidationTest
 
-noncomputable def cvmStagedUniverseInput := cvmStagedUniverseInputTest
+def cvmStagedUniverseInput := cvmStagedUniverseInputTest
 
-noncomputable def cvmStagedPostFamilyInput := cvmStagedPostFamilyInputTest
+def cvmStagedPostFamilyInput := cvmStagedPostFamilyInputTest
 
 theorem cvmSafetyRunDirect :
     AddInductive.checkConstructorPreFamilySafety
@@ -11278,7 +11438,7 @@ theorem cvmSafetyRun :
         .ok () :=
   cvmSafetyRunTest
 
-noncomputable def cvmStagedPreFamilyInput := cvmStagedPreFamilyInputTest
+def cvmStagedPreFamilyInput := cvmStagedPreFamilyInputTest
 
 /- The accepted CVM package may inherit the ordinary verified-checker
 transition frontier and the one exact L4L-01E execution witness, but no
@@ -11308,9 +11468,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.cvmStagedPreFamilyInput' depends on axi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert,
  cvmExecutionResult_isOk._native.native_decide.ax_1_1]
@@ -11362,7 +11525,7 @@ theorem cvmCanonicalCandidate_produced :
   rw [← cvmCandidate_eq_canonical]
   exact cvmCandidate_produced
 
-noncomputable abbrev cvmCanonicalStagedPreFamilyInput :
+abbrev cvmCanonicalStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       cvmFamilyContext cvmConstructorContext VEnv.empty [`u]
       cvmCanonicalCandidate constructorValidityMatrixDecl :=
@@ -11466,19 +11629,24 @@ theorem cvmExactProducedGenerationCandidatePackage_exists :
       constructorValidityMatrixGenerationChecked
     cvmCandidate_analysis
 
-private noncomputable def cvmExactProducedGenerationCandidatePackage :
+private def cvmExactProducedGenerationCandidatePackage :
     VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u]
       cvmProducedGenerationShapeCandidate
       constructorValidityMatrixGenerationChecked :=
-  Classical.choice cvmExactProducedGenerationCandidatePackage_exists
+  cvmProducedGenerationShapeCandidate.exactProducedPackage
+    cvmCanonicalStagedPreFamilyInput
+      (stagedPreFamily_transport_raw cvmCandidate_eq_canonical
+        cvmStagedPreFamilyInput).symm
+      constructorValidityMatrixGenerationChecked
+    cvmCandidate_analysis
 
-noncomputable def cvmGenerationCandidateSemanticRun :
+def cvmGenerationCandidateSemanticRun :
     VInductDecl.GenerationCandidateSemanticRun
       cvmExactProducedGenerationCandidatePackage.normalization
       constructorValidityMatrixGenerationChecked :=
   cvmExactProducedGenerationCandidatePackage.semantic
 
-noncomputable def cvmProducedGenerationCandidatePackage :
+def cvmProducedGenerationCandidatePackage :
     VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] :=
   cvmExactProducedGenerationCandidatePackage.package
 
@@ -11557,7 +11725,7 @@ theorem prbCanonicalCandidate_produced :
   rw [← prbCandidate_eq_canonical]
   exact prbCandidate_produced
 
-noncomputable abbrev prbCanonicalStagedPreFamilyInput :
+abbrev prbCanonicalStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       prbFamilyContext prbConstructorContext VEnv.empty [`u]
       prbCanonicalCandidate propRecursiveBoundaryDecl :=
@@ -11661,19 +11829,23 @@ theorem prbExactProducedGenerationCandidatePackage_exists :
       prbStagedPreFamilyInput).symm propRecursiveBoundaryGenerationChecked
     prbCandidate_analysis
 
-private noncomputable def prbExactProducedGenerationCandidatePackage :
+private def prbExactProducedGenerationCandidatePackage :
     VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u]
       prbProducedGenerationShapeCandidate
       propRecursiveBoundaryGenerationChecked :=
-  Classical.choice prbExactProducedGenerationCandidatePackage_exists
+  prbProducedGenerationShapeCandidate.exactProducedPackage
+    prbCanonicalStagedPreFamilyInput
+    (stagedPreFamily_transport_raw prbCandidate_eq_canonical
+      prbStagedPreFamilyInput).symm propRecursiveBoundaryGenerationChecked
+    prbCandidate_analysis
 
-noncomputable def prbGenerationCandidateSemanticRun :
+def prbGenerationCandidateSemanticRun :
     VInductDecl.GenerationCandidateSemanticRun
       prbExactProducedGenerationCandidatePackage.normalization
       propRecursiveBoundaryGenerationChecked :=
   prbExactProducedGenerationCandidatePackage.semantic
 
-noncomputable def prbProducedGenerationCandidatePackage :
+def prbProducedGenerationCandidatePackage :
     VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] :=
   prbExactProducedGenerationCandidatePackage.package
 
@@ -11823,7 +11995,7 @@ theorem cvmReplayRec_fresh :
     SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
   simp [constructorValidityMatrixType, SMap.find?]
 
-noncomputable def cvmAddInductTraceChecked :
+def cvmAddInductTraceChecked :
     AddInductTrace ({} : ConstMap) VEnv.empty constructorValidityMatrixDecl
       cvmReplayMap cvmCertifiedFinalEnv := by
   refine cvmProducedGenerationCandidatePackage.package.addInductTrace
@@ -12064,7 +12236,7 @@ theorem prbReplayRec_fresh :
     SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
   simp [propRecursiveBoundaryType, SMap.find?]
 
-noncomputable def prbAddInductTraceChecked :
+def prbAddInductTraceChecked :
     AddInductTrace ({} : ConstMap) VEnv.empty propRecursiveBoundaryDecl
       prbReplayMap prbCertifiedFinalEnv := by
   refine prbProducedGenerationCandidatePackage.package.addInductTrace
diff --git a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean
new file mode 100644
index 00000000..da669047
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean
@@ -0,0 +1,793 @@
+import Lean4Lean.Verify.Environment.NestedReplay
+
+/-!
+# Deep, multi-parameter nested replay
+
+`BiBox` supplies an actual two-parameter dependency block. `DeepBi` then
+nests through `BiBox` twice: the second occurrence is discovered only while
+the first auxiliary constructor is processed.  The pair exercises both
+simultaneous parameter substitution and the flattening work queue beyond the
+original one-parameter ladder fixtures.
+-/
+
+namespace Lean4Lean.DeepNestedReplayFixtures
+
+open Lean
+open Lean4Lean.InductiveReplayFixtures
+open Lean4Lean.NestedRepresentation
+open VInductDecl
+
+/- `nestedBlockChecked?` is executable Theory data.  Reify one of its closed
+generated equations as constructor syntax so the ordinary `type_tac` checker
+can audit the equation without unfolding the analyzer.  This is the same
+elaboration-time quotation boundary used by the kernel-metadata macros; the
+subsequent `rfl` parity lemmas below separately pin every quoted RHS to the
+actual stored recursor metadata. -/
+syntax "computedVDefEq%" term : term
+
+elab_rules : term
+  | `(computedVDefEq% $rule:term) => do
+    let e ← Lean.Elab.Term.elabTerm rule (Lean.mkConst ``VDefEq)
+    let e ← Lean.instantiateMVars e
+    let value ← unsafe Lean.Meta.evalExpr VDefEq (Lean.mkConst ``VDefEq) e
+    return Lean.toExpr value
+
+local instance : Inhabited VEnv := ⟨.empty⟩
+local instance : Inhabited VConstVal :=
+  ⟨⟨⟨0, .sort .zero⟩, .anonymous⟩⟩
+local instance : Inhabited VDefEq :=
+  ⟨⟨0, .sort .zero, .sort .zero, .sort (.succ .zero)⟩⟩
+
+/-! ## An actual two-parameter dependency replay -/
+
+inductive BiBox (α β : Type) : Type where
+  | mk : α → β → BiBox α β
+
+def biBoxType : VInductiveType where
+  name := ``BiBox
+  uvars := 0
+  type := nestedConstVType09A% BiBox
+  ctors := [⟨⟨0, nestedConstVType09A% BiBox.mk⟩, ``BiBox.mk⟩]
+
+def biBoxDecl : VInductDecl where
+  uvars := 0
+  nparams := 2
+  types := [biBoxType]
+
+def biBoxChecked : biBoxDecl.Checked :=
+  biBoxDecl.checked?.get (by decide)
+
+def biBoxGeneration : biBoxDecl.GenerationChecked :=
+  biBoxDecl.identityGeneration?.get (by decide)
+
+def biBoxFamilyV : VConstVal := biBoxType.toVConstVal
+def biBoxCtorV : VConstVal := biBoxType.ctors[0]
+def biBoxRecV : VConstVal := inductGenerationRecVal biBoxGeneration
+
+/-- The executable analyzer's concrete view of the actual dependency block.
+Keep these observations in one named trust-manifest entry. -/
+theorem biBoxObservedShape :
+    biBoxChecked.type.name = ``BiBox ∧
+    biBoxChecked.resultLevel = .succ .zero ∧
+    biBoxChecked.indices = [] ∧
+    biBoxChecked.params.reverse =
+      [.sort (.succ .zero), .sort (.succ .zero)] ∧
+    biBoxGeneration.block.sourceType.ctors = [biBoxCtorV] := by
+  native_decide
+
+theorem biBoxCheckedWF : biBoxChecked.WF VEnv.empty := by
+  constructor
+  · change VEnv.empty.OnTel 0 []
+      [.sort (.succ .zero), .sort (.succ .zero)]
+    exact ⟨⟨.succ (.succ .zero), VEnv.HasType.sort (by decide)⟩,
+      ⟨⟨.succ (.succ .zero), VEnv.HasType.sort (by decide)⟩, trivial⟩⟩
+  · intro ctor hctor
+    have hctor' := List.mem_singleton.1 hctor
+    subst ctor
+    obtain ⟨hname, hresult, hindices, hparams, -⟩ := biBoxObservedShape
+    constructor
+    · rw [show biBoxDecl.uvars = 0 from rfl,
+        hname,
+        show biBoxDecl.nparams = 2 from rfl,
+        hresult, hindices, hparams]
+      change VInductDecl.fieldsWF 0 ``BiBox 2 VEnv.empty
+        (.succ .zero) [] [.sort (.succ .zero), .sort (.succ .zero)] 0
+        [.bvar 1, .bvar 1]
+      constructor
+      · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac,
+          .inr (VLevel.le_refl _)⟩)
+      constructor
+      · intro recursive
+        contradiction
+      constructor
+      · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac,
+          .inr (VLevel.le_refl _)⟩)
+      constructor
+      · intro recursive
+        contradiction
+      · trivial
+    · rw [show biBoxDecl.uvars = 0 from rfl,
+        show biBoxDecl.nparams = 2 from rfl,
+        hresult, hindices, hparams]
+      exact .nil
+
+def biBoxGenerationWF : biBoxGeneration.WF VEnv.empty := by
+  exact biBoxCheckedWF.identityGeneration .empty
+
+def biBoxTypeEnv : VEnv :=
+  (VEnv.empty.addConst biBoxFamilyV.name biBoxFamilyV.toVConstant).get!
+
+def biBoxCtorEnv : VEnv :=
+  (biBoxTypeEnv.addConst biBoxCtorV.name biBoxCtorV.toVConstant).get!
+
+def biBoxRecEnv : VEnv :=
+  (biBoxCtorEnv.addConst biBoxRecV.name biBoxRecV.toVConstant).get!
+
+def biBoxFinalEnv : VEnv :=
+  biBoxGeneration.generatedRules.foldl VEnv.addDefEq biBoxRecEnv
+
+def biBoxInfo : ConstantInfo := kernelInductInfo% BiBox
+def biBoxMkInfo : ConstantInfo := kernelCtorInfo% BiBox.mk
+def biBoxRecInfo : ConstantInfo := kernelRecInfo% BiBox.rec
+
+def biBoxTypeMap : ConstMap :=
+  ({} : ConstMap).insert ``BiBox biBoxInfo
+
+def biBoxCtorMap : ConstMap :=
+  biBoxTypeMap.insert ``BiBox.mk biBoxMkInfo
+
+def biBoxMap : ConstMap :=
+  biBoxCtorMap.insert ``BiBox.rec biBoxRecInfo
+
+theorem biBoxTypeEnvOrdered : biBoxTypeEnv.Ordered :=
+  replayTypeEnv_ordered07 .empty biBoxGenerationWF rfl
+
+theorem biBoxCtorEnvOrdered : biBoxCtorEnv.Ordered :=
+  replayCtorEnv_ordered07 biBoxGenerationWF rfl biBoxTypeEnvOrdered rfl
+
+def biBoxGenerationEnv :
+    VInductDecl.GenerationEnv biBoxGeneration biBoxCtorEnv :=
+  replayGenerationEnv07 biBoxGenerationWF rfl rfl biBoxCtorEnvOrdered
+
+theorem biBoxInfoTr :
+    TrConstVal .safe VEnv.empty biBoxInfo biBoxFamilyV := by
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr VEnv.empty biBoxInfo.levelParams []
+      biBoxInfo.type biBoxFamilyV.type := by
+    tr_type_expr_tac
+  obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 biBoxGenerationWF
+  exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩
+
+theorem biBoxCtorInfoTr :
+    TrConstVal .safe biBoxTypeEnv biBoxMkInfo biBoxCtorV := by
+  have hBiBox : biBoxTypeEnv.constants ``BiBox =
+      some biBoxFamilyV.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr biBoxTypeEnv biBoxMkInfo.levelParams []
+      biBoxMkInfo.type biBoxCtorV.type := by
+    tr_type_expr_tac
+  have hctors := biBoxObservedShape.2.2.2.2
+  obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 biBoxGenerationWF rfl
+    biBoxCtorV (by rw [hctors]; simp)
+  exact shape.to_trExprS biBoxTypeEnvOrdered trivial
+    ⟨.sort sort, ctorType⟩
+
+theorem biBoxRecInfoTr :
+    TrConstVal .safe biBoxCtorEnv biBoxRecInfo biBoxRecV := by
+  have hBiBox : biBoxCtorEnv.constants ``BiBox =
+      some biBoxFamilyV.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr biBoxCtorEnv biBoxRecInfo.levelParams []
+      biBoxRecInfo.type biBoxRecV.type := by
+    tr_type_expr_tac
+  obtain ⟨sort, recursorType⟩ := biBoxGenerationEnv.recursor_wf
+  exact shape.to_trExprS biBoxCtorEnvOrdered trivial
+    ⟨.sort sort, recursorType⟩
+
+theorem biBoxTypeFresh : ({} : ConstMap).find? ``BiBox = none := by
+  simp [SMap.find?]
+
+theorem biBoxTypeMapWF : biBoxTypeMap.WF :=
+  SMap.WF.empty.insert _ _ biBoxTypeFresh
+
+theorem biBoxCtorFresh : biBoxTypeMap.find? ``BiBox.mk = none := by
+  rw [biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem biBoxCtorMapWF : biBoxCtorMap.WF :=
+  biBoxTypeMapWF.insert _ _ biBoxCtorFresh
+
+theorem biBoxRecFresh : biBoxCtorMap.find? ``BiBox.rec = none := by
+  rw [biBoxCtorMap, biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem biBoxAddInduct : AddInduct ({} : ConstMap) VEnv.empty biBoxDecl
+    biBoxMap biBoxFinalEnv := by
+  refine ⟨{
+    generation := biBoxGeneration
+    generation_wf := biBoxGenerationWF
+    typeMap := biBoxTypeMap
+    typeEnv := biBoxTypeEnv
+    ctorMap := biBoxCtorMap
+    ctorEnv := biBoxCtorEnv
+    recEnv := biBoxRecEnv
+    addType := {
+      info := biBoxInfo
+      kind_eq := by simp [biBoxInfo, InductConstantKind.Matches]
+      tr := biBoxInfoTr
+      map_fresh := biBoxTypeFresh
+      env_add := rfl
+      map_add := rfl }
+    addCtors := ?_
+    addRec := {
+      info := biBoxRecInfo
+      kind_eq := by simp [biBoxRecInfo, InductConstantKind.Matches]
+      tr := biBoxRecInfoTr
+      map_fresh := biBoxRecFresh
+      env_add := rfl
+      map_add := rfl }
+    recK := by decide
+    addRules := ⟨rfl⟩ }⟩
+  exact .cons {
+    info := biBoxMkInfo
+    kind_eq := by simp [biBoxMkInfo, InductConstantKind.Matches]
+    tr := biBoxCtorInfoTr
+    map_fresh := by simpa [biBoxCtorV, biBoxType] using biBoxCtorFresh
+    env_add := rfl
+    map_add := rfl } .nil
+
+theorem biBoxAligned : Aligned .safe biBoxMap biBoxFinalEnv :=
+  Aligned.addInduct biBoxAddInduct .empty
+
+def biBoxReplay : SingletonReplayArtifact where
+  label := ``BiBox
+  source := biBoxDecl
+  inputMap := {}
+  inputEnv := .empty
+  inputMapWF := SMap.WF.empty
+  outputMap := biBoxMap
+  outputEnv := biBoxFinalEnv
+  inputOrdered := .empty
+  transaction := biBoxAddInduct
+  aligned := biBoxAligned
+
+/-! ## Analyzer-produced deep nested block -/
+
+inductive DeepBi (α β : Type) : Type where
+  | node : BiBox (DeepBi α β) (BiBox α (DeepBi α β)) → DeepBi α β
+
+def biBoxTarget : NestedTargetBlock where
+  nparams := 2
+  families := biBoxDecl.types
+
+def deepSourceV : VInductDecl where
+  uvars := 0
+  nparams := 2
+  types :=
+    [{ name := ``DeepBi
+       uvars := 0
+       type := nestedConstVType09A% DeepBi
+       ctors :=
+         [⟨⟨0, nestedConstVType09A% DeepBi.node⟩, ``DeepBi.node⟩] }]
+
+def deepNestedC? : Option (NestedBlockChecked deepSourceV) :=
+  nestedBlockChecked? [biBoxTarget] deepSourceV
+
+#guard deepNestedC?.isSome
+
+theorem deepNestedC_some : deepNestedC?.isSome := by
+  native_decide
+
+def deepNestedC : NestedBlockChecked deepSourceV :=
+  deepNestedC?.get deepNestedC_some
+
+theorem deepNestedC_produced :
+    nestedBlockChecked? [biBoxTarget] deepSourceV = some deepNestedC := by
+  change deepNestedC? = some deepNestedC
+  exact (Option.some_get deepNestedC_some).symm
+
+#guard deepNestedC.elim.numNested == 2
+#guard deepNestedC.recursors.length == 3
+#guard deepNestedC.recursors.map (·.name) ==
+  [``DeepBi.rec,
+   `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1,
+   `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2]
+
+def deepFamilyV : VConstVal := deepSourceV.types[0].toVConstVal
+def deepNodeV : VConstVal := deepSourceV.types[0].ctors[0]
+
+def deepRecTypeL : VExpr := nestedConstVType09A% DeepBi.rec
+def deepRec1TypeL : VExpr := nestedConstVType09A% DeepBi.rec_1
+def deepRec2TypeL : VExpr := nestedConstVType09A% DeepBi.rec_2
+
+def deepRecVL : VConstVal :=
+  ⟨⟨1, deepRecTypeL⟩, ``DeepBi.rec⟩
+def deepRec1VL : VConstVal :=
+  ⟨⟨1, deepRec1TypeL⟩,
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1⟩
+def deepRec2VL : VConstVal :=
+  ⟨⟨1, deepRec2TypeL⟩,
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2⟩
+
+theorem deepRecursors_eq :
+    deepNestedC.recursors = [deepRecVL, deepRec1VL, deepRec2VL] := by
+  native_decide
+
+def deepRule0L : VDefEq :=
+  computedVDefEq% deepNestedC.generatedRules[0]!
+def deepRule1L : VDefEq :=
+  computedVDefEq% deepNestedC.generatedRules[1]!
+def deepRule2L : VDefEq :=
+  computedVDefEq% deepNestedC.generatedRules[2]!
+
+def deepRulesL : List VDefEq := [deepRule0L, deepRule1L, deepRule2L]
+
+theorem deepRules_eq : deepNestedC.generatedRules = deepRulesL := by
+  native_decide
+
+/- Each analyzer-produced rule is pinned to the corresponding rule emitted
+by Lean for the actual declaration.  The equality is definitional after the
+two independent elaboration-time quotations. -/
+theorem deepRule0_rhs_metadata :
+    deepRule0L.rhs = kernelRecRuleRhs% DeepBi.rec 0 := by
+  rfl
+
+theorem deepRule1_rhs_metadata :
+    deepRule1L.rhs = kernelRecRuleRhs% DeepBi.rec_1 0 := by
+  rfl
+
+theorem deepRule2_rhs_metadata :
+    deepRule2L.rhs = kernelRecRuleRhs% DeepBi.rec_2 0 := by
+  rfl
+
+/-! ## Exact semantic phase environments -/
+
+def deepTypeEnv : VEnv :=
+  (biBoxFinalEnv.addConst deepFamilyV.name deepFamilyV.toVConstant).get!
+
+def deepCtorEnv : VEnv :=
+  (deepTypeEnv.addConst deepNodeV.name deepNodeV.toVConstant).get!
+
+def deepRecEnv : VEnv :=
+  (deepCtorEnv.addConst deepRecVL.name deepRecVL.toVConstant).get!
+
+def deepRec1Env : VEnv :=
+  (deepRecEnv.addConst deepRec1VL.name deepRec1VL.toVConstant).get!
+
+def deepRec2Env : VEnv :=
+  (deepRec1Env.addConst deepRec2VL.name deepRec2VL.toVConstant).get!
+
+def deepFinalEnv : VEnv :=
+  deepRulesL.foldl VEnv.addDefEq deepRec2Env
+
+theorem biBoxTrEnv : TrEnv' .safe biBoxMap false biBoxFinalEnv :=
+  .induct biBoxAddInduct .empty
+
+theorem biBoxFinalOrdered : biBoxFinalEnv.Ordered :=
+  biBoxTrEnv.wf.ordered
+
+theorem biBoxFinalWF : biBoxFinalEnv.WF :=
+  biBoxTrEnv.wf
+
+theorem deepFamilyWF : deepFamilyV.toVConstant.WF biBoxFinalEnv :=
+  ⟨_, by type_tac⟩
+
+theorem deepTypeEnv_eq :
+    biBoxFinalEnv.addConst deepFamilyV.name deepFamilyV.toVConstant =
+      some deepTypeEnv := rfl
+
+theorem deepTypeOrdered : deepTypeEnv.Ordered :=
+  .const biBoxFinalOrdered deepFamilyWF deepTypeEnv_eq
+
+theorem deepNodeWF : deepNodeV.toVConstant.WF deepTypeEnv := by
+  have hBiBox : deepTypeEnv.constants ``BiBox =
+      some biBoxFamilyV.toVConstant := rfl
+  have hDeep : deepTypeEnv.constants ``DeepBi =
+      some deepFamilyV.toVConstant := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem deepCtorEnv_eq :
+    deepTypeEnv.addConst deepNodeV.name deepNodeV.toVConstant =
+      some deepCtorEnv := rfl
+
+theorem deepCtorOrdered : deepCtorEnv.Ordered :=
+  .const deepTypeOrdered deepNodeWF deepCtorEnv_eq
+
+macro "deep_const_hyps" e:term : tactic => `(tactic| (
+  have hBiBox : VEnv.constants $e ``BiBox =
+      some biBoxFamilyV.toVConstant := rfl
+  have hBiBoxMk : VEnv.constants $e ``BiBox.mk =
+      some biBoxCtorV.toVConstant := rfl
+  have hDeep : VEnv.constants $e ``DeepBi =
+      some deepFamilyV.toVConstant := rfl
+  have hNode : VEnv.constants $e ``DeepBi.node =
+      some deepNodeV.toVConstant := rfl))
+
+set_option maxRecDepth 20000 in
+theorem deepRecWF : deepRecVL.toVConstant.WF deepCtorEnv := by
+  deep_const_hyps deepCtorEnv
+  exact ⟨_, by type_tac⟩
+
+theorem deepRecEnv_eq :
+    deepCtorEnv.addConst deepRecVL.name deepRecVL.toVConstant =
+      some deepRecEnv := rfl
+
+theorem deepRecOrdered : deepRecEnv.Ordered :=
+  .const deepCtorOrdered deepRecWF deepRecEnv_eq
+
+set_option maxRecDepth 20000 in
+theorem deepRec1WF : deepRec1VL.toVConstant.WF deepRecEnv := by
+  deep_const_hyps deepRecEnv
+  exact ⟨_, by type_tac⟩
+
+theorem deepRec1Env_eq :
+    deepRecEnv.addConst deepRec1VL.name deepRec1VL.toVConstant =
+      some deepRec1Env := rfl
+
+theorem deepRec1Ordered : deepRec1Env.Ordered :=
+  .const deepRecOrdered deepRec1WF deepRec1Env_eq
+
+set_option maxRecDepth 20000 in
+theorem deepRec2WF : deepRec2VL.toVConstant.WF deepRec1Env := by
+  deep_const_hyps deepRec1Env
+  exact ⟨_, by type_tac⟩
+
+theorem deepRec2Env_eq :
+    deepRec1Env.addConst deepRec2VL.name deepRec2VL.toVConstant =
+      some deepRec2Env := rfl
+
+theorem deepRec2Ordered : deepRec2Env.Ordered :=
+  .const deepRec1Ordered deepRec2WF deepRec2Env_eq
+
+/-! ## Restored rule well-formedness -/
+
+macro "deep_rule_hyps" e:term : tactic => `(tactic| (
+  deep_const_hyps $e
+  have hRec : VEnv.constants $e ``DeepBi.rec =
+      some deepRecVL.toVConstant := rfl
+  have hRec1 : VEnv.constants $e
+      `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 =
+      some deepRec1VL.toVConstant := rfl
+  have hRec2 : VEnv.constants $e
+      `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 =
+      some deepRec2VL.toVConstant := rfl))
+
+def deepRuleEnv1 : VEnv := deepRec2Env.addDefEq deepRule0L
+def deepRuleEnv2 : VEnv := deepRuleEnv1.addDefEq deepRule1L
+
+set_option maxRecDepth 30000 in
+theorem deepRule0WF : deepRule0L.WF deepRec2Env := by
+  constructor
+  · deep_rule_hyps deepRec2Env
+    type_tac
+  · deep_rule_hyps deepRec2Env
+    type_tac
+
+set_option maxRecDepth 30000 in
+theorem deepRule1WF : deepRule1L.WF deepRuleEnv1 := by
+  constructor
+  · deep_rule_hyps deepRuleEnv1
+    type_tac
+  · deep_rule_hyps deepRuleEnv1
+    type_tac
+
+set_option maxRecDepth 30000 in
+theorem deepRule2WF : deepRule2L.WF deepRuleEnv2 := by
+  constructor
+  · deep_rule_hyps deepRuleEnv2
+    type_tac
+  · deep_rule_hyps deepRuleEnv2
+    type_tac
+
+/-! ## Semantic package and exact nested transaction phases -/
+
+theorem deepTypesFold_eq :
+    deepSourceV.blockTypeConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) biBoxFinalEnv =
+      some deepTypeEnv := rfl
+
+theorem deepCtorsFold_eq :
+    deepSourceV.blockConstructorConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) deepTypeEnv =
+      some deepCtorEnv := rfl
+
+theorem deepRecsFold_eq :
+    deepNestedC.recursors.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) deepCtorEnv =
+      some deepRec2Env := by
+  rw [deepRecursors_eq]
+  rfl
+
+theorem deepNestedWF : deepNestedC.WF biBoxFinalEnv := by
+  refine ⟨⟨deepFamilyWF, fun env' h => ?_⟩, fun {typeEnv} h => ?_,
+    fun {typeEnv ctorEnv} hT hC => ?_,
+    fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩
+  · cases Option.some.inj (deepTypeEnv_eq.symm.trans h)
+    exact trivial
+  · cases Option.some.inj (deepTypesFold_eq.symm.trans h)
+    exact ⟨deepNodeWF, fun env' h' => by
+      cases Option.some.inj (deepCtorEnv_eq.symm.trans h')
+      exact trivial⟩
+  · cases Option.some.inj (deepTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (deepCtorsFold_eq.symm.trans hC)
+    rw [deepRecursors_eq]
+    exact ⟨deepRecWF, fun env' h' => by
+      cases Option.some.inj (deepRecEnv_eq.symm.trans h')
+      exact ⟨deepRec1WF, fun env'' h'' => by
+        cases Option.some.inj (deepRec1Env_eq.symm.trans h'')
+        exact ⟨deepRec2WF, fun env''' h''' => by
+          cases Option.some.inj (deepRec2Env_eq.symm.trans h''')
+          exact trivial⟩⟩⟩
+  · cases Option.some.inj (deepTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (deepCtorsFold_eq.symm.trans hC)
+    cases Option.some.inj (deepRecsFold_eq.symm.trans hR)
+    rw [deepRules_eq]
+    exact ⟨deepRule0WF, deepRule1WF, deepRule2WF, trivial⟩
+
+/-! ## Actual stored metadata and implementation maps -/
+
+def deepInfo : ConstantInfo := kernelInductInfo% DeepBi
+def deepNodeInfo : ConstantInfo := kernelCtorInfo% DeepBi.node
+def deepRecInfo : ConstantInfo := kernelRecInfo% DeepBi.rec
+def deepRec1Info : ConstantInfo := kernelRecInfo% DeepBi.rec_1
+def deepRec2Info : ConstantInfo := kernelRecInfo% DeepBi.rec_2
+
+def deepTypeMap : ConstMap :=
+  biBoxMap.insert ``DeepBi deepInfo
+
+def deepCtorMap : ConstMap :=
+  deepTypeMap.insert ``DeepBi.node deepNodeInfo
+
+def deepRecMap : ConstMap :=
+  deepCtorMap.insert ``DeepBi.rec deepRecInfo
+
+def deepRec1Map : ConstMap :=
+  deepRecMap.insert
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 deepRec1Info
+
+def deepMap : ConstMap :=
+  deepRec1Map.insert
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 deepRec2Info
+
+theorem biBoxMapWF : biBoxMap.WF :=
+  biBoxCtorMapWF.insert _ _ biBoxRecFresh
+
+theorem deepTypeFresh : biBoxMap.find? ``DeepBi = none := by
+  rw [biBoxMap, biBoxCtorMapWF.find?_insert, biBoxCtorMap,
+    biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem deepTypeMapWF : deepTypeMap.WF :=
+  biBoxMapWF.insert _ _ deepTypeFresh
+
+theorem deepNodeFresh : deepTypeMap.find? ``DeepBi.node = none := by
+  rw [deepTypeMap, biBoxMapWF.find?_insert, biBoxMap,
+    biBoxCtorMapWF.find?_insert, biBoxCtorMap,
+    biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem deepCtorMapWF : deepCtorMap.WF :=
+  deepTypeMapWF.insert _ _ deepNodeFresh
+
+theorem deepRecFresh : deepCtorMap.find? ``DeepBi.rec = none := by
+  rw [deepCtorMap, deepTypeMapWF.find?_insert, deepTypeMap,
+    biBoxMapWF.find?_insert, biBoxMap,
+    biBoxCtorMapWF.find?_insert, biBoxCtorMap,
+    biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem deepRecMapWF : deepRecMap.WF :=
+  deepCtorMapWF.insert _ _ deepRecFresh
+
+theorem deepRec1Fresh : deepRecMap.find?
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 = none := by
+  rw [deepRecMap, deepCtorMapWF.find?_insert, deepCtorMap,
+    deepTypeMapWF.find?_insert, deepTypeMap,
+    biBoxMapWF.find?_insert, biBoxMap,
+    biBoxCtorMapWF.find?_insert, biBoxCtorMap,
+    biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem deepRec1MapWF : deepRec1Map.WF :=
+  deepRecMapWF.insert _ _ deepRec1Fresh
+
+theorem deepRec2Fresh : deepRec1Map.find?
+    `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 = none := by
+  rw [deepRec1Map, deepRecMapWF.find?_insert, deepRecMap,
+    deepCtorMapWF.find?_insert, deepCtorMap,
+    deepTypeMapWF.find?_insert, deepTypeMap,
+    biBoxMapWF.find?_insert, biBoxMap,
+    biBoxCtorMapWF.find?_insert, biBoxCtorMap,
+    biBoxTypeMapWF.find?_insert, biBoxTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+/-! ## Stored metadata translations at the exact insertion boundaries -/
+
+theorem deepInfoTr :
+    TrConstVal .safe biBoxFinalEnv deepInfo deepFamilyV := by
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr biBoxFinalEnv deepInfo.levelParams []
+      deepInfo.type deepFamilyV.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := deepFamilyWF
+  exact shape.to_trExprS biBoxFinalOrdered trivial ⟨_, hty⟩
+
+theorem deepNodeInfoTr :
+    TrConstVal .safe deepTypeEnv deepNodeInfo deepNodeV := by
+  have hBiBox : deepTypeEnv.constants ``BiBox =
+      some biBoxFamilyV.toVConstant := rfl
+  have hDeep : deepTypeEnv.constants ``DeepBi =
+      some deepFamilyV.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr deepTypeEnv deepNodeInfo.levelParams []
+      deepNodeInfo.type deepNodeV.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := deepNodeWF
+  exact shape.to_trExprS deepTypeOrdered trivial ⟨_, hty⟩
+
+set_option maxRecDepth 20000 in
+theorem deepRecInfoTr :
+    TrConstVal .safe deepCtorEnv deepRecInfo deepRecVL := by
+  deep_const_hyps deepCtorEnv
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr deepCtorEnv deepRecInfo.levelParams []
+      deepRecInfo.type deepRecVL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := deepRecWF
+  exact shape.to_trExprS deepCtorOrdered trivial ⟨_, hty⟩
+
+set_option maxRecDepth 20000 in
+theorem deepRec1InfoTr :
+    TrConstVal .safe deepRecEnv deepRec1Info deepRec1VL := by
+  deep_const_hyps deepRecEnv
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr deepRecEnv deepRec1Info.levelParams []
+      deepRec1Info.type deepRec1VL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := deepRec1WF
+  exact shape.to_trExprS deepRecOrdered trivial ⟨_, hty⟩
+
+set_option maxRecDepth 20000 in
+theorem deepRec2InfoTr :
+    TrConstVal .safe deepRec1Env deepRec2Info deepRec2VL := by
+  deep_const_hyps deepRec1Env
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr deepRec1Env deepRec2Info.levelParams []
+      deepRec2Info.type deepRec2VL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := deepRec2WF
+  exact shape.to_trExprS deepRec1Ordered trivial ⟨_, hty⟩
+
+/-! ## Recursor flags, final lookups, and the replay trace -/
+
+theorem deepMapWF : deepMap.WF :=
+  deepRec1MapWF.insert _ _ deepRec2Fresh
+
+theorem deepKTarget : deepNestedC.generation.kTarget = false := by
+  native_decide
+
+theorem deepRecLookup :
+    deepMap.find? ``DeepBi.rec = some deepRecInfo := by
+  rw [deepMap, deepRec1MapWF.find?_insert, deepRec1Map,
+    deepRecMapWF.find?_insert, deepRecMap,
+    deepCtorMapWF.find?_insert]
+  simp
+
+theorem deepRec1Lookup :
+    deepMap.find?
+      `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 =
+        some deepRec1Info := by
+  rw [deepMap, deepRec1MapWF.find?_insert]
+  simp [deepRec1Map, deepRecMapWF.find?_insert]
+
+theorem deepRec2Lookup :
+    deepMap.find?
+      `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 =
+        some deepRec2Info := by
+  rw [deepMap, deepRec1MapWF.find?_insert]
+  simp
+
+theorem deepRecK :
+    RecursorMapKMatches deepMap deepNestedC.recursors
+      deepNestedC.generation.kTarget := by
+  rw [deepRecursors_eq, deepKTarget]
+  intro recursor hmem
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨deepRecInfo, deepRecLookup, by decide⟩
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨deepRec1Info, deepRec1Lookup, by decide⟩
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨deepRec2Info, deepRec2Lookup, by decide⟩
+  · cases hmem
+
+def deepTrace :
+    AddInductNestedTrace biBoxMap biBoxFinalEnv deepSourceV
+      deepMap deepFinalEnv where
+  nested := deepNestedC
+  nested_wf := deepNestedWF
+  typeMap := deepTypeMap
+  typeEnv := deepTypeEnv
+  ctorMap := deepCtorMap
+  ctorEnv := deepCtorEnv
+  recEnv := deepRec2Env
+  addTypes := .cons
+    { info := deepInfo
+      kind_eq := by simp [deepInfo, InductConstantKind.Matches]
+      tr := deepInfoTr
+      map_fresh := deepTypeFresh
+      env_add := deepTypeEnv_eq
+      map_add := rfl } .nil
+  addCtors := .cons
+    { info := deepNodeInfo
+      kind_eq := by simp [deepNodeInfo, InductConstantKind.Matches]
+      tr := deepNodeInfoTr
+      map_fresh := deepNodeFresh
+      env_add := deepCtorEnv_eq
+      map_add := rfl } .nil
+  addRecs := deepRecursors_eq ▸ .cons
+    { info := deepRecInfo
+      kind_eq := by simp [deepRecInfo, InductConstantKind.Matches]
+      tr := deepRecInfoTr
+      map_fresh := deepRecFresh
+      env_add := deepRecEnv_eq
+      map_add := rfl } (.cons
+    { info := deepRec1Info
+      kind_eq := by simp [deepRec1Info, InductConstantKind.Matches]
+      tr := deepRec1InfoTr
+      map_fresh := deepRec1Fresh
+      env_add := deepRec1Env_eq
+      map_add := rfl } (.cons
+    { info := deepRec2Info
+      kind_eq := by simp [deepRec2Info, InductConstantKind.Matches]
+      tr := deepRec2InfoTr
+      map_fresh := deepRec2Fresh
+      env_add := deepRec2Env_eq
+      map_add := rfl } .nil))
+  recK := deepRecK
+  addRules := ⟨by rw [deepRules_eq]; rfl⟩
+
+theorem deepAddInductNested :
+    AddInductNested biBoxMap biBoxFinalEnv deepSourceV
+      deepMap deepFinalEnv :=
+  ⟨deepTrace⟩
+
+theorem deepTrEnv : TrEnv' .safe deepMap false deepFinalEnv :=
+  .inductNested deepAddInductNested biBoxTrEnv
+
+theorem deepFinalOrdered : deepFinalEnv.Ordered :=
+  deepTrEnv.wf.ordered
+
+theorem deepFinalWF : deepFinalEnv.WF :=
+  deepTrEnv.wf
+
+theorem deepAddInductNested_success :
+    biBoxFinalEnv.addInductNested deepNestedC = some deepFinalEnv :=
+  deepTrace.to_addInductNested
+
+/- The replay is now free of `sorryAx`; its remaining native-decision and
+persistent-map closure is recorded exactly below. The Theory certificate
+exported from this trace has the stricter guards in `InductiveCertificate`. -/
+/--
+info: 'Lean4Lean.DeepNestedReplayFixtures.deepTrEnv' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ PersistentHashMap.findAux_isSome,
+ PersistentHashMap.WF.find?_eq,
+ PersistentHashMap.WF.toList'_insert,
+ biBoxObservedShape._native.native_decide.ax_1_1,
+ deepKTarget._native.native_decide.ax_1_1,
+ deepNestedC_some._native.native_decide.ax_1_1,
+ deepRecursors_eq._native.native_decide.ax_1_1,
+ deepRules_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms deepTrEnv
+
+end Lean4Lean.DeepNestedReplayFixtures
diff --git a/Lean4Lean/Verify/Environment/Elimination.lean b/Lean4Lean/Verify/Environment/Elimination.lean
index 6f027e77..9f0c87ed 100644
--- a/Lean4Lean/Verify/Environment/Elimination.lean
+++ b/Lean4Lean/Verify/Environment/Elimination.lean
@@ -6,11 +6,11 @@ open Lean hiding Environment Exception
 
 namespace AddInductive
 
-/-- Theory's presentation of the Boolean returned by the ordinary
-large-eliminator checker. -/
-def checkerElimMode : Bool → VInductDecl.ElimMode
-  | false => .small
-  | true => .large
+/-- Compatibility name for Theory's presentation of the Boolean returned by
+the ordinary large-eliminator checker. -/
+@[deprecated VInductDecl.ElimMode.ofBool (since := "2026-08-11")]
+abbrev checkerElimMode : Bool → VInductDecl.ElimMode :=
+  VInductDecl.ElimMode.ofBool
 
 /-- Lightweight alignment for an exact `getElimLevel` execution when the
 normalization statistics are already pinned independently. This is useful for
@@ -22,7 +22,7 @@ structure CheckerElimLevelRun
     (execution : ElimLevelExecution stats indTypes context) : Type where
   sourceUvars_eq : source.uvars = context.lparams.length
   mode_eq : generation.elimination =
-    checkerElimMode execution.large.result
+    VInductDecl.ElimMode.ofBool execution.large.result
   recUvars_eq : generation.recUvars =
     (getRecLevelParams execution.level context.lparams).length
   recLevels_eq :
@@ -42,7 +42,7 @@ def build?
     Option (CheckerElimLevelRun generation execution) := do
   if huvars : source.uvars = context.lparams.length then
     if hmode : generation.elimination =
-        checkerElimMode execution.large.result then
+        VInductDecl.ElimMode.ofBool execution.large.result then
       if hrecUvars : generation.recUvars =
           (getRecLevelParams execution.level context.lparams).length then
         if hlevels :
@@ -67,11 +67,11 @@ theorem large_result_iff
   cases hresult : execution.large.result with
   | false =>
       have hmode : generation.elimination = VInductDecl.ElimMode.small := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
   | true =>
       have hmode : generation.elimination = VInductDecl.ElimMode.large := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
 
 theorem small_result_iff
@@ -81,11 +81,11 @@ theorem small_result_iff
   cases hresult : execution.large.result with
   | false =>
       have hmode : generation.elimination = VInductDecl.ElimMode.small := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
   | true =>
       have hmode : generation.elimination = VInductDecl.ElimMode.large := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
 
 end CheckerElimLevelRun
@@ -143,7 +143,7 @@ structure CheckerEliminationRun
   sourceUvars_eq : source.uvars =
     execution.normalization.validationContext.lparams.length
   mode_eq : generation.elimination =
-    checkerElimMode execution.elimination.large.result
+    VInductDecl.ElimMode.ofBool execution.elimination.large.result
   kTarget_eq : generation.kTarget = execution.kTarget.result
   recUvars_eq : generation.recUvars = execution.recLevelParams.length
   recLevels_eq : execution.recLevels.mapM
@@ -164,7 +164,7 @@ def build?
     if huvars : source.uvars =
         execution.normalization.validationContext.lparams.length then
       if hmode : generation.elimination =
-          checkerElimMode execution.elimination.large.result then
+          VInductDecl.ElimMode.ofBool execution.elimination.large.result then
         if hkTarget : generation.kTarget = execution.kTarget.result then
           if hrecUvars : generation.recUvars =
               execution.recLevelParams.length then
@@ -192,11 +192,11 @@ theorem large_result_iff
   cases hresult : execution.elimination.large.result with
   | false =>
       have hmode : generation.elimination = VInductDecl.ElimMode.small := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
   | true =>
       have hmode : generation.elimination = VInductDecl.ElimMode.large := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
 
 theorem small_result_iff
@@ -206,11 +206,11 @@ theorem small_result_iff
   cases hresult : execution.elimination.large.result with
   | false =>
       have hmode : generation.elimination = VInductDecl.ElimMode.small := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
   | true =>
       have hmode : generation.elimination = VInductDecl.ElimMode.large := by
-        simpa [checkerElimMode, hresult] using run.mode_eq
+        simpa [hresult] using run.mode_eq
       simp [hmode]
 
 theorem kTarget_result_true_iff
diff --git a/Lean4Lean/Verify/Environment/Extension.lean b/Lean4Lean/Verify/Environment/Extension.lean
new file mode 100644
index 00000000..1529846d
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/Extension.lean
@@ -0,0 +1,618 @@
+import Lean4Lean.Verify.Environment.Checker
+
+namespace Lean4Lean
+open Lean4Lean
+open Lean hiding Environment Exception
+open Kernel
+
+open private Lean.Kernel.Environment.add from Lean.Environment
+
+theorem TrEnv.exists_addConst (H : TrEnv safety env venv) (hn : env.find? name = none)
+    (ci' : VConstant) : ∃ venv', venv.addConst name ci' = some venv' := by
+  unfold VEnv.addConst
+  cases hfind : venv.constants name with
+  | none => simp
+  | some ci => obtain ⟨ci, hci, _⟩ := H.find?_iff.2 ⟨ci, hfind⟩; cases hn ▸ hci
+
+theorem VEnv.addConst_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ ≤ env₂)
+    (h₁ : env₁.addConst name ci = some env₁') (h₂ : env₂.addConst name ci = some env₂') :
+    env₁' ≤ env₂' := by
+  unfold VEnv.addConst at h₁ h₂
+  split at h₁ <;> cases h₁
+  split at h₂ <;> cases h₂
+  refine { constants {n a} := ?_, defeqs := H.defeqs, structEtas := H.structEtas }
+  dsimp; split <;> [exact id; exact H.constants]
+
+theorem VEnv.addDefEq_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) :
+    env₁.addDefEq df ≤ env₂.addDefEq df where
+  constants := H.constants
+  defeqs := by rintro d (rfl | hd) <;> [exact .inl rfl; exact .inr (H.defeqs hd)]
+  structEtas := H.structEtas
+
+theorem VEnv.addConsts_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ ≤ env₂) :
+    ∀ {cis}, env₁.addConsts cis = some env₁' → env₂.addConsts cis = some env₂' → env₁' ≤ env₂'
+  | [], h₁, h₂ => by cases h₁; cases h₂; exact H
+  | _ :: _, h₁, h₂ => by
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at h₁ h₂
+    obtain ⟨_, e₁, h₁⟩ := h₁; obtain ⟨_, e₂, h₂⟩ := h₂
+    exact VEnv.addConsts_mono (VEnv.addConst_mono H e₁ e₂) h₁ h₂
+
+theorem VEnv.addDefEqs_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) :
+    ∀ {cis}, env₁.addDefEqs cis ≤ env₂.addDefEqs cis
+  | [] => H
+  | _ :: _ => VEnv.addDefEqs_mono (VEnv.addDefEq_mono H)
+
+theorem VEnv.addConst_eq_of_ne
+    {env env' : VEnv}
+    (hadd : env.addConst name ci = some env') (hne : name ≠ n) :
+    env'.constants n = env.constants n := by
+  unfold VEnv.addConst at hadd
+  split at hadd <;> cases hadd
+  simp [hne]
+
+theorem VEnv.HasPrimitives.addConst_of_not_primitive {env env' : VEnv} (H : env.HasPrimitives)
+    (hname : Environment.primitives.contains name = false)
+    (hadd : env.addConst name ci = some env') : env'.HasPrimitives := by
+  have le := VEnv.addConst_le hadd
+  have same {n} (hp : Environment.primitives.contains n = true) :
+      env'.constants n = env.constants n :=
+    VEnv.addConst_eq_of_ne hadd fun h => by subst h; simp_all
+  have oldContains {n} (hp : Environment.primitives.contains n = true) :
+      env'.contains n → env.contains n := fun ⟨ci, hci⟩ => ⟨ci, (same hp) ▸ hci⟩
+  have newContains {n} : env.contains n → env'.contains n := fun ⟨ci, hci⟩ => ⟨ci, le.constants hci⟩
+  refine let prims := _; have hprims : Environment.primitives = .ofList prims := rfl; ?_
+  replace hprims {n} : n ∈ prims → Environment.primitives.contains n := by
+    simp [hprims, NameSet.contains, NameSet.ofList]
+  simp only [List.mem_cons, prims] at hprims
+  constructor
+  · intro h
+    let ⟨h1, h2⟩ := H.bool (oldContains (hprims (by simp)) h)
+    exact ⟨newContains h1, newContains h2⟩
+  · intro ci h; apply H.boolFalse; rwa [← same (hprims (by simp))]
+  · intro ci h; apply H.boolTrue; rwa [← same (hprims (by simp))]
+  · intro h
+    let ⟨h1, h2⟩ := H.nat (oldContains (hprims (by simp)) h)
+    exact ⟨newContains h1, newContains h2⟩
+  · intro ci h; apply H.natZero; rwa [← same (hprims (by simp))]
+  · intro ci h; apply H.natSucc; rwa [← same (hprims (by simp))]
+  · intro h a b; exact (H.natAdd (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natSub (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natMul (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natPow (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natGcd (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natMod (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natDiv (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natBEq (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natBLE (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natLAnd (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natLOr (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natXor (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natShiftLeft (oldContains (hprims (by simp)) h) a b).mono le
+  · intro h a b; exact (H.natShiftRight (oldContains (hprims (by simp)) h) a b).mono le
+  · intro ci h; apply H.charOfNat; rwa [← same (hprims (by simp))]
+  · intro ci h
+    obtain ⟨rfl, h2, h3⟩ := H.stringOfList (by rwa [← same (hprims (by simp))])
+    exact ⟨rfl, h2.mono le, h3.mono le⟩
+
+theorem VEnv.HasPrimitives.addDefEq {env : VEnv} (H : env.HasPrimitives) :
+    (env.addDefEq df).HasPrimitives :=
+  { H with
+    natAdd h a b := (H.natAdd h a b).mono VEnv.addDefEq_le
+    natSub h a b := (H.natSub h a b).mono VEnv.addDefEq_le
+    natMul h a b := (H.natMul h a b).mono VEnv.addDefEq_le
+    natPow h a b := (H.natPow h a b).mono VEnv.addDefEq_le
+    natGcd h a b := (H.natGcd h a b).mono VEnv.addDefEq_le
+    natMod h a b := (H.natMod h a b).mono VEnv.addDefEq_le
+    natDiv h a b := (H.natDiv h a b).mono VEnv.addDefEq_le
+    natBEq h a b := (H.natBEq h a b).mono VEnv.addDefEq_le
+    natBLE h a b := (H.natBLE h a b).mono VEnv.addDefEq_le
+    natLAnd h a b := (H.natLAnd h a b).mono VEnv.addDefEq_le
+    natLOr h a b := (H.natLOr h a b).mono VEnv.addDefEq_le
+    natXor h a b := (H.natXor h a b).mono VEnv.addDefEq_le
+    natShiftLeft h a b := (H.natShiftLeft h a b).mono VEnv.addDefEq_le
+    natShiftRight h a b := (H.natShiftRight h a b).mono VEnv.addDefEq_le
+    stringOfList h :=
+      let ⟨h1, h2, h3⟩ := H.stringOfList h
+      ⟨h1, h2.mono VEnv.addDefEq_le, h3.mono VEnv.addDefEq_le⟩ }
+
+theorem safePrimitives_add' {env : Environment} (mapWF : env.constants.WF)
+    (old : ∀ {n : Name} {ci}, env.find? n = some ci →
+      Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [])
+    (ci : ConstantInfo) (hfresh : env.find? ci.name = none)
+    (hok : Environment.primitives.contains ci.name → ci.safety = .safe ∧ ci.levelParams = [])
+    (hfind : (env.add ci).find? (n : Name) = some ci')
+    (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] := by
+  have hnone : env.constants.find? ci.name = none := by
+    rw [← mapWF.find?'_eq_find?]; exact hfresh
+  have mapWF' := mapWF.insert ci.name ci hnone
+  change SMap.find?' (env.constants.insert ci.name ci) n = some ci' at hfind
+  rw [mapWF'.find?'_eq_find?, mapWF.find?_insert] at hfind
+  split at hfind
+  · cases hfind; cases LawfulBEq.eq_of_beq ‹_›; exact hok hp
+  · refine old ?_ hp; rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?]
+
+theorem VEnvs.WF.safePrimitives_add {ves : VEnvs} {env : Environment}
+    (wf : ves.WF env) (ci : ConstantInfo)
+    (hfresh : env.find? ci.name = none)
+    (hok : Environment.primitives.contains ci.name →
+      ci.safety = .safe ∧ ci.levelParams = [])
+    (hfind : (env.add ci).find? (n : Name) = some ci')
+    (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] :=
+  safePrimitives_add' (wf.tr (safety := .safe)).map_wf wf.safePrimitives ci hfresh hok hfind hp
+
+theorem VEnvAt.safePrimitives_add {env : Environment} {venv : VEnv}
+    (wf : VEnvAt env safety venv) (ci : ConstantInfo)
+    (hfresh : env.find? ci.name = none)
+    (hok : Environment.primitives.contains ci.name →
+      ci.safety = .safe ∧ ci.levelParams = [])
+    (hfind : (env.add ci).find? (n : Name) = some ci')
+    (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] :=
+  safePrimitives_add' wf.tr.map_wf wf.safePrimitives ci hfresh hok hfind hp
+
+theorem VEnv.HasPrimitives.addConsts {env env' : VEnv} : ∀ {cis : List VDefVal},
+    env.HasPrimitives → (∀ ci ∈ cis, Environment.primitives.contains ci.name = false) →
+    env.addConsts cis = some env' → env'.HasPrimitives
+  | [], H, _, e => by cases e; exact H
+  | _ :: _, H, hn, e => by
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at e
+    obtain ⟨_, h1, h2⟩ := e
+    exact addConsts (H.addConst_of_not_primitive (hn _ (.head _)) h1) (fun c hc => hn c (.tail _ hc)) h2
+
+theorem VEnv.HasPrimitives.addDefEqs {env : VEnv} : ∀ {cis : List VDefVal},
+    env.HasPrimitives → (env.addDefEqs cis).HasPrimitives
+  | [], H => H
+  | _ :: cis, H => addDefEqs (cis := cis) H.addDefEq
+
+theorem TrEnv.constants_eq_none (H : TrEnv safety env venv) (hn : env.find? name = none) :
+    venv.constants name = none := by
+  cases hfind : venv.constants name with
+  | none => rfl
+  | some ci => obtain ⟨ci, hci, _⟩ := H.find?_iff.2 ⟨ci, hfind⟩; cases hn ▸ hci
+
+theorem TrEnv.exists_addConsts (H : TrEnv safety env venv) {cis : List VDefVal}
+    (hfresh : ∀ ci ∈ cis, env.find? ci.name = none)
+    (hnd : (cis.map (·.name)).Nodup) : ∃ venv', venv.addConsts cis = some venv' :=
+  VEnv.exists_addConsts (fun ci hci => H.constants_eq_none (hfresh ci hci)) hnd
+
+theorem insertDefs_wf : ∀ {cis : List DefinitionVal} {C : ConstMap}, C.WF →
+    (∀ d ∈ cis, C.find? d.name = none) → (cis.map (·.name)).Nodup → (insertDefs C cis).WF
+  | [], _, hC, _, _ => hC
+  | d :: ds, C, hC, hfr, hnd => by
+    rw [List.map_cons, List.nodup_cons] at hnd
+    refine insertDefs_wf (cis := ds) (hC.insert _ _ (hfr _ (.head _))) (fun e he => ?_) hnd.2
+    rw [hC.find?_insert, if_neg]; · exact hfr e (.tail _ he)
+    simp only [beq_iff_eq]; intro hh
+    exact hnd.1 (List.mem_map.2 ⟨e, he, hh.symm⟩)
+
+theorem Environment.constants_addDefs : ∀ {vs : List DefinitionVal} {env : Environment},
+    (vs.foldl (fun e v => Lean.Kernel.Environment.add e (.defnInfo v)) env).constants =
+    insertDefs env.constants vs
+  | [], _ => rfl
+  | v :: vs, env => Environment.constants_addDefs (vs := vs) (env := env.add (.defnInfo v))
+
+theorem VEnvs.WF.safePrimitives_addDefs {ves : VEnvs} {env : Environment}
+    (wf : ves.WF env) {vs : List DefinitionVal}
+    (hfresh : ∀ v ∈ vs, env.find? v.name = none)
+    (hnd : (vs.map (·.name)).Nodup)
+    (hnonprim : ∀ v ∈ vs, Environment.primitives.contains v.name = false)
+    (hfind : (vs.foldl (fun e v => e.add (.defnInfo v)) env).find? n = some ci)
+    (hp : Environment.primitives.contains n) : ci.safety = .safe ∧ ci.levelParams = [] := by
+  have mapWF := (wf.tr (safety := .safe)).map_wf
+  have hfr : ∀ d ∈ vs, env.constants.find? d.name = none := fun d hd => by
+    rw [← mapWF.find?'_eq_find?]; exact hfresh d hd
+  rw [Kernel.Environment.find?, Environment.constants_addDefs,
+    (insertDefs_wf mapWF hfr hnd).find?'_eq_find?] at hfind
+  rcases insertDefs_find? mapWF hfr hnd hfind with h | ⟨d, hd, rfl, rfl⟩
+  · exact wf.safePrimitives (by rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?]) hp
+  · exact absurd hp (by simp [hnonprim d hd])
+
+theorem Environment.quotInit_addDefs : ∀ {vs : List DefinitionVal} {env : Environment},
+    (vs.foldl (fun e v => Lean.Kernel.Environment.add e (.defnInfo v)) env).quotInit =
+    env.quotInit
+  | [], _ => rfl
+  | _ :: vs, _ => quotInit_addDefs (vs := vs)
+
+/-- A block of definitions that is invisible at `safety` extends the constant map without
+touching the model, one `TrEnv'.ignore` per member. -/
+theorem TrEnv'.ignoreDefs : ∀ {vs : List DefinitionVal} {C : ConstMap},
+    (∀ v ∈ vs, ¬ safety ≤ (ConstantInfo.defnInfo v).safety) →
+    (∀ v ∈ vs, C.find? v.name = none) → (vs.map (·.name)).Nodup →
+    TrEnv' safety C Q venv → TrEnv' safety (insertDefs C vs) Q venv
+  | [], _, _, _, _, H => H
+  | d :: ds, C, hvis, hfr, hnd, H => by
+    rw [List.map_cons, List.nodup_cons] at hnd
+    have H' := TrEnv'.ignore (ci := .defnInfo d) (hfr _ (.head _)) (hvis _ (.head _)) H
+    show TrEnv' safety (insertDefs (SMap.insert C d.name (.defnInfo d)) ds) Q _
+    refine TrEnv'.ignoreDefs (fun e he => hvis e (.tail _ he)) (fun e he => ?_) hnd.2 H'
+    rw [H.map_wf.find?_insert, if_neg]; · exact hfr e (.tail _ he)
+    simp only [beq_iff_eq]; intro hh
+    exact hnd.1 (List.mem_map.2 ⟨e, he, hh.symm⟩)
+
+theorem Environment.find?_add_of_ne {env : Environment} (mapWF : env.constants.WF)
+    (ci : ConstantInfo) (hfresh : env.find? ci.name = none) {n : Name}
+    (hne : ci.name ≠ n) (h : env.find? n = none) : (env.add ci).find? n = none := by
+  have hnone : env.constants.find? ci.name = none := by rwa [← mapWF.find?'_eq_find?]
+  have mapWF' := mapWF.insert ci.name ci hnone
+  change SMap.find?' (env.constants.insert ci.name ci) n = none
+  rw [mapWF'.find?'_eq_find?, mapWF.find?_insert, if_neg (by simpa using hne)]
+  rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?] at h
+
+/-- Data produced by `addMutual`'s header loop for one block member. -/
+def TrMutualHeader (bs : DefinitionSafety) (venv : VEnv) (env : Environment)
+    (v : DefinitionVal) (ci : VDefVal) : Prop :=
+  TrConstVal bs venv (.defnInfo v) ci.toVConstVal ∧
+  ci.toVConstant.WF venv ∧ env.find? v.name = none ∧
+  Environment.primitives.contains v.name = false
+
+/-- A model of the temporary environment in which a mutual block's bodies are checked: every
+member has been added as an axiom, so a body may refer to any member of the block (including
+itself) but cannot delta-unfold it. -/
+theorem VEnvAt.addAxioms {env : Environment} {venv : VEnv} {bs : DefinitionSafety}
+    (hsf : bs ≤ (if bs == .unsafe then DefinitionSafety.unsafe else .safe)) :
+    ∀ {vs : List DefinitionVal} {cis : List VDefVal} {venv' : VEnv},
+      VEnvAt env bs venv →
+      List.Forall₂ (TrMutualHeader bs venv env) vs cis →
+      (vs.map (·.name)).Nodup →
+      venv.addConsts cis = some venv' →
+      VEnvAt (vs.foldl (fun e v => e.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) env)
+        bs venv'
+  | [], _, _, wf, .nil, _, e => by cases e; exact wf
+  | v :: vs, ci :: cis, venv', wf, .cons hd tl, hnd, e => by
+    rw [List.map_cons, List.nodup_cons] at hnd
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at e
+    obtain ⟨venv₁, h₁, h₂⟩ := e
+    have hn : v.name = ci.name := hd.1.2
+    have h₁' : venv.addConst v.name ci.toVConstant = some venv₁ := by rw [hn]; exact h₁
+    have hle := VEnv.addConst_le h₁'
+    have hax : (ConstantInfo.axiomInfo { v with isUnsafe := bs == .unsafe }).name = v.name := rfl
+    -- The existing extension-readiness obligation supplies both checker
+    -- capabilities.  Keeping them paired preserves this declaration's single
+    -- reconciliation placeholder while the shared transport theorem is proved.
+    have readiness :
+        ProjectionReady (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) venv₁ ∧
+        StructureEtaReady (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) venv₁ :=
+      sorry
+    have wf₁ : VEnvAt (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) bs venv₁ :=
+      { tr := TrEnv'.axiom (ci := { v with isUnsafe := bs == .unsafe }) (ci' := ci.toVConstant)
+          ⟨hsf, hd.1.1.2.1, hd.1.1.2.2⟩
+          (by rw [← wf.tr.map_wf.find?'_eq_find?]; exact hd.2.2.1) hd.2.1 h₁' wf.tr
+        hasPrimitives := wf.hasPrimitives.addConst_of_not_primitive hd.2.2.2 h₁'
+        safePrimitives := wf.safePrimitives_add _ (hax ▸ hd.2.2.1)
+          (by rw [hax]; simp [hd.2.2.2])
+        -- Tier V (L4L-19B): checker-readiness transport across the temporary
+        -- axiom additions of a mutual-block body environment. Added at the
+        -- v4.33 reconciliation, where upstream's proved front-end chains met
+        -- this fork's projection-readiness obligation on `VContext`; the
+        -- `infer` half needs `isProjectionReadyStructure` stability under
+        -- `Environment.add`, which is new verification content, not merge
+        -- resolution.
+        projectionReady := readiness.1
+        structureEtaReady := readiness.2 }
+    show VEnvAt (vs.foldl (fun e v => e.add (.axiomInfo { v with isUnsafe := bs == .unsafe }))
+      (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe }))) bs venv'
+    refine VEnvAt.addAxioms hsf wf₁ ?_ hnd.2 h₂
+    refine tl.and_mem.imp fun w cj h => ?_
+    obtain ⟨h, hw, -⟩ := h
+    have hne : v.name ≠ w.name := fun hh => hnd.1 (List.mem_map.2 ⟨w, hw, hh.symm⟩)
+    exact ⟨⟨⟨h.1.1.1, h.1.1.2.1, h.1.1.2.2.mono hle⟩, h.1.2⟩, h.2.1.mono hle,
+      Environment.find?_add_of_ne wf.tr.map_wf _ (hax ▸ hd.2.2.1) (hax ▸ hne) h.2.2.1,
+      h.2.2.2⟩
+
+/-- Add a whole mutual block. The headers were checked in `env`, the bodies in the temporary
+environment holding the entire block, which is `base` on the model side; `TrEnv'.mutualDef`
+consumes exactly that split.
+
+Like `addUnsafeDef.WF` this cannot conclude `VEnv.AddDef` for the members: the bodies may
+refer to each other, so they do not translate before the block is added. -/
+theorem addMutualBlock.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (bs : DefinitionSafety) (vs : List DefinitionVal) (cis : List VDefVal) (base : VEnv)
+    (hbs : ∀ v ∈ vs, v.safety = bs)
+    (hnd : (vs.map (·.name)).Nodup)
+    (hfresh : ∀ v ∈ vs, env.find? v.name = none)
+    (hnonprim : ∀ v ∈ vs, Environment.primitives.contains v.name = false)
+    (hwfc : ∀ ci ∈ cis, ci.toVConstant.WF (ves.venv bs))
+    (hbase : (ves.venv bs).addConsts cis = some base)
+    (htr : TrDefBlock bs (ves.venv bs) base vs cis)
+    (hci : ∀ ci ∈ cis, ci.WF base) :
+    ∃ ves' : VEnvs, ves'.WF (vs.foldl (fun e v => e.add (.defnInfo v)) env) ∧
+      ∀ safety, ves.venv safety ≤ ves'.venv safety := by
+  have hname := htr.imp (fun _ _ h => h.1.2)
+  have hmapeq : vs.map (·.name) = cis.map (·.name) := by
+    rwa [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff]
+  have hndCis : (cis.map (·.name)).Nodup := hmapeq ▸ hnd
+  have hpull {P : Name → Prop} (H : ∀ v ∈ vs, P v.name) : ∀ ci ∈ cis, P ci.name := by
+    intro ci hc
+    obtain ⟨v, hv, hn⟩ := hname.forall_exists_r ci hc
+    exact hn ▸ H v hv
+  have hfreshCis := hpull (P := fun n => env.find? n = none) hfresh
+  have hnonprimCis := hpull (P := fun n => Environment.primitives.contains n = false) hnonprim
+  have hfreshMap : ∀ v ∈ vs, env.constants.find? v.name = none := fun v hv => by
+    rw [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?]; exact hfresh v hv
+  have hvis_iff (sf) (hv : sf ≤ bs) (v) (hmem : v ∈ vs) :
+      sf ≤ (ConstantInfo.defnInfo v).safety := by
+    rw [ConstantInfo.defnInfo_safety, hbs v hmem]; exact hv
+  -- the model at each visible safety level
+  have hves' sf : ∃ venv',
+      if sf ≤ bs then ∃ b, (ves.venv sf).addConsts cis = some b ∧ venv' = b.addDefEqs cis
+      else venv' = ves.venv sf := by
+    split <;> [skip; exact ⟨_, rfl⟩]
+    obtain ⟨b, hb⟩ := (wf.tr (safety := sf)).exists_addConsts hfreshCis hndCis
+    exact ⟨_, b, hb, rfl⟩
+  obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves'
+  have hbaseSf (sf) (hv : sf ≤ bs) : ∃ b, (ves.venv sf).addConsts cis = some b ∧
+      ves'.venv sf = b.addDefEqs cis := by
+    have h := hves' sf; rw [if_pos hv] at h; exact h
+  have hsame (sf) (hv : ¬ sf ≤ bs) : ves'.venv sf = ves.venv sf := by
+    have h := hves' sf; rwa [if_neg hv] at h
+  refine ⟨ves', ?_, fun sf => by
+    by_cases hv : sf ≤ bs
+    · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv
+      exact heq ▸ (VEnv.addConsts_le hb).trans VEnv.addDefEqs_le
+    · rw [hsame sf hv]; exact VEnv.LE.rfl⟩
+  have readiness : ∀ sf,
+      ProjectionReady (vs.foldl (fun e v => e.add (.defnInfo v)) env) (ves'.venv sf) ∧
+      StructureEtaReady (vs.foldl (fun e v => e.add (.defnInfo v)) env) (ves'.venv sf) :=
+    sorry
+  exact {
+    tr {sf} := by
+      show TrEnv sf _ _
+      unfold TrEnv
+      rw [Environment.constants_addDefs, Environment.quotInit_addDefs]
+      by_cases hv : sf ≤ bs
+      · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv
+        have hmono : ves.venv bs ≤ ves.venv sf := wf.mono hv
+        have hbmono : base ≤ b := VEnv.addConsts_mono hmono hbase hb
+        refine heq ▸ TrEnv'.mutualDef (env := ves.venv sf) (env' := b) ?_ hnd hfreshMap
+          (fun ci hc => (hwfc ci hc).mono hmono) hb
+          (fun ci hc => (hci ci hc).mono hbmono) (wf.tr (safety := sf))
+        exact htr.imp fun _ _ h => ⟨⟨(h.1.1.sf_mono hv).mono hmono, h.1.2⟩, h.2.mono hbmono⟩
+      · rw [hsame sf hv]
+        exact TrEnv'.ignoreDefs
+          (fun v hmem => fun h => hv (by rwa [ConstantInfo.defnInfo_safety, hbs v hmem] at h))
+          hfreshMap hnd (wf.tr (safety := sf))
+    hasPrimitives {sf} := by
+      by_cases hv : sf ≤ bs
+      · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv
+        exact heq ▸ ((wf.hasPrimitives (safety := sf)).addConsts hnonprimCis hb).addDefEqs
+      · rw [hsame sf hv]; exact wf.hasPrimitives
+    safePrimitives := wf.safePrimitives_addDefs hfresh hnd hnonprim
+    mono {sf sf'} hle := by
+      by_cases hv' : sf' ≤ bs
+      · have hv : sf ≤ bs := DefinitionSafety.le_trans hle hv'
+        obtain ⟨b', hb', heq'⟩ := hbaseSf sf' hv'
+        obtain ⟨b, hb, heq⟩ := hbaseSf sf hv
+        rw [heq', heq]
+        exact VEnv.addDefEqs_mono (VEnv.addConsts_mono (wf.mono hle) hb' hb)
+      · rw [hsame sf' hv']
+        by_cases hv : sf ≤ bs
+        · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv
+          rw [heq]
+          exact (wf.mono hle).trans ((VEnv.addConsts_le hb).trans VEnv.addDefEqs_le)
+        · rw [hsame sf hv]; exact wf.mono hle
+    -- Tier V (L4L-19B): checker-readiness transport across this front-end
+    -- extension; see `VEnvAt.addAxioms`.
+    projectionReady {sf} := (readiness sf).1
+    structureEtaReady {sf} := (readiness sf).2 }
+
+theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety)
+    (visible_le : ∀ safety, safety ≤ ci.safety → safety ≤ checkSafety)
+    (htr : TrConstVal checkSafety (ves.venv checkSafety) ci ci')
+    (hci : ci'.toVConstant.WF (ves.venv checkSafety))
+    (hn : env.find? ci.name = none)
+    (hprim : Environment.primitives.contains ci.name →
+      ci.safety = .safe ∧ ci.levelParams = [])
+    (preserves : ∀ safety venv', safety ≤ ci.safety →
+      (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' →
+      (ves.venv safety).HasPrimitives → venv'.HasPrimitives)
+    (step : ∀ safety venv',
+      TrConstant safety (ves.venv safety) ci ci'.toVConstant →
+      ci'.toVConstant.WF (ves.venv safety) →
+      (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' →
+      TrEnv' safety env.constants env.quotInit (ves.venv safety) →
+      TrEnv' safety (env.constants.insert ci.name ci) env.quotInit venv') :
+    ∃ ves' : VEnvs, ves'.WF (env.add ci) ∧
+      ∀ safety, (ves.venv safety).AddConst safety ci ci'.toVConstant (ves'.venv safety) := by
+  have hnMap : env.constants.find? ci.name = none := by
+    rw [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?]
+    exact hn
+  have visible_tr (safety) (hvisible : safety ≤ ci.safety) :
+      TrConstant safety (ves.venv safety) ci ci'.toVConstant :=
+    (htr.1.sf_mono (visible_le safety hvisible)).mono (wf.mono (visible_le safety hvisible))
+  have visible_wf (safety) (hvisible : safety ≤ ci.safety) :
+      ci'.toVConstant.WF (ves.venv safety) :=
+    hci.mono (wf.mono (visible_le safety hvisible))
+  have hves' safety : ∃ venv', (ves.venv safety).AddConst safety ci ci'.toVConstant venv' := by
+    unfold VEnv.AddConst; split <;> [rename_i hvisible; exact ⟨ves.venv safety, rfl⟩]
+    have ⟨venv', hadd⟩ := (wf.tr (safety := safety)).exists_addConst hn ci'.toVConstant
+    exact ⟨venv', visible_tr safety hvisible, visible_wf safety hvisible, hadd⟩
+  obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves'
+  have hadd (safety) (hvisible : safety ≤ ci.safety) :
+      (ves.venv safety).addConst ci.name ci'.toVConstant = some (ves'.venv safety) := by
+    have h := hves' safety; unfold VEnv.AddConst at h; rw [if_pos hvisible] at h; exact h.2.2
+  have hsame (safety) (hvisible : ¬ safety ≤ ci.safety) : ves'.venv safety = ves.venv safety := by
+    have h := hves' safety; unfold VEnv.AddConst at h; rwa [if_neg hvisible] at h
+  refine ⟨ves', ?_, hves'⟩
+  have readiness : ∀ safety,
+      ProjectionReady (env.add ci) (ves'.venv safety) ∧
+      StructureEtaReady (env.add ci) (ves'.venv safety) :=
+    sorry
+  exact {
+    tr {safety} := by
+      by_cases hvisible : safety ≤ ci.safety
+      · exact step safety _ (visible_tr safety hvisible) (visible_wf safety hvisible)
+          (hadd safety hvisible) (wf.tr (safety := safety))
+      · rw [hsame safety hvisible]
+        exact TrEnv'.ignore (ci := ci) hnMap hvisible (wf.tr (safety := safety))
+    hasPrimitives {safety} := by
+      by_cases hvisible : safety ≤ ci.safety
+      · exact preserves safety _ hvisible (hadd safety hvisible) (wf.hasPrimitives (safety := safety))
+      · rw [hsame safety hvisible]; exact wf.hasPrimitives (safety := safety)
+    safePrimitives := wf.safePrimitives_add ci hn hprim
+    mono {safety safety'} hle := by
+      by_cases hvisible' : safety' ≤ ci.safety
+      · have hvisible := DefinitionSafety.le_trans hle hvisible'
+        exact VEnv.addConst_mono (wf.mono hle) (hadd safety' hvisible') (hadd safety hvisible)
+      rw [hsame safety' hvisible']
+      by_cases hvisible : safety ≤ ci.safety
+      · exact (wf.mono hle).trans (VEnv.addConst_le (hadd safety hvisible))
+      · rw [hsame safety hvisible]; exact wf.mono hle
+    -- Tier V (L4L-19B): checker-readiness transport across this front-end
+    -- extension; see `VEnvAt.addAxioms`.
+    projectionReady {safety} := (readiness safety).1
+    structureEtaReady {safety} := (readiness safety).2 }
+
+theorem addConst.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety)
+    (visible_le : ∀ safety, safety ≤ ci.safety → safety ≤ checkSafety)
+    (htr : TrConstVal checkSafety (ves.venv checkSafety) ci ci')
+    (hci : ci'.toVConstant.WF (ves.venv checkSafety))
+    (hn : env.find? ci.name = none)
+    (hnonprim : Environment.primitives.contains ci.name = false)
+    (step : ∀ safety venv',
+      TrConstant safety (ves.venv safety) ci ci'.toVConstant →
+      ci'.toVConstant.WF (ves.venv safety) →
+      (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' →
+      TrEnv' safety env.constants env.quotInit (ves.venv safety) →
+      TrEnv' safety (env.constants.insert ci.name ci) env.quotInit venv') :
+    ∃ ves' : VEnvs, ves'.WF (env.add ci) ∧
+      ∀ safety, (ves.venv safety).AddConst safety ci ci'.toVConstant (ves'.venv safety) :=
+  addConstCore.WF wf ci ci' checkSafety visible_le htr hci hn (by simp_all)
+    (fun _ _ _ hadd hp => hp.addConst_of_not_primitive hnonprim hadd) step
+
+theorem addDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : DefinitionVal) (ci' : VDefVal) (checkSafety : DefinitionSafety)
+    (visible_le : ∀ safety, safety ≤ (ConstantInfo.defnInfo v).safety → safety ≤ checkSafety)
+    (htr : TrDefVal checkSafety (ves.venv checkSafety) (.defnInfo v) ci')
+    (hci : ci'.WF (ves.venv checkSafety))
+    (hn : env.find? v.name = none)
+    (hprim : Environment.primitives.contains v.name →
+      (ConstantInfo.defnInfo v).safety = .safe ∧ v.levelParams = [])
+    (preserves : ∀ safety base,
+      safety ≤ (ConstantInfo.defnInfo v).safety →
+      (ves.venv safety).addConst v.name ci'.toVConstant = some base →
+      (base.addDefEq ci'.toDefEq).HasPrimitives) :
+    ∃ ves' : VEnvs, ves'.WF (env.add (.defnInfo v)) ∧
+      ∀ safety, (ves.venv safety).AddDef safety (.defnInfo v) ci' (ves'.venv safety) := by
+  have hnMap : env.constants.find? v.name = none := by
+    rwa [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?]
+  have visible_tr (safety) (hvisible : safety ≤ (ConstantInfo.defnInfo v).safety) :
+      TrDefVal safety (ves.venv safety) (.defnInfo v) ci' :=
+    .mono (wf.mono (visible_le safety hvisible)) <|
+      ⟨⟨htr.1.1.sf_mono (visible_le safety hvisible), htr.1.2⟩, htr.2⟩
+  have visible_wf safety hvisible := hci.mono (wf.mono (visible_le safety hvisible))
+  have hves' safety : ∃ venv', (ves.venv safety).AddDef safety (.defnInfo v) ci' venv' := by
+    unfold VEnv.AddDef; split <;> [rename_i hvisible; exact ⟨ves.venv safety, rfl⟩]
+    have ⟨base, hadd⟩ := (wf.tr (safety := safety)).exists_addConst hn ci'.toVConstant
+    exact ⟨base.addDefEq ci'.toDefEq,
+      base, visible_tr safety hvisible, visible_wf safety hvisible, hadd, rfl⟩
+  obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves'
+  have hbase (safety) (hvisible : safety ≤ (ConstantInfo.defnInfo v).safety) :
+      ∃ base, (ves.venv safety).addConst v.name ci'.toVConstant = some base ∧
+        ves'.venv safety = base.addDefEq ci'.toDefEq := by
+    have h := hves' safety; unfold VEnv.AddDef at h; rw [if_pos hvisible] at h
+    obtain ⟨base, _, _, hadd, heq⟩ := h; exact ⟨base, hadd, heq⟩
+  have hsame (safety) (hvisible : ¬ safety ≤ (ConstantInfo.defnInfo v).safety) :
+      ves'.venv safety = ves.venv safety := by
+    have h := hves' safety; unfold VEnv.AddDef at h; rwa [if_neg hvisible] at h
+  refine ⟨ves', ?_, hves'⟩
+  have readiness : ∀ safety,
+      ProjectionReady (env.add (.defnInfo v)) (ves'.venv safety) ∧
+      StructureEtaReady (env.add (.defnInfo v)) (ves'.venv safety) :=
+    sorry
+  refine {
+    tr {safety} := by
+      change TrEnv' safety (env.constants.insert v.name (.defnInfo v)) env.quotInit _
+      by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety
+      · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible
+        exact heq ▸ TrEnv'.defn (visible_tr safety hvisible)
+          (by rwa [← (wf.tr (safety := safety)).map_wf.find?'_eq_find?])
+          (visible_wf safety hvisible) hadd (wf.tr (safety := safety))
+      · rw [hsame safety hvisible]
+        simpa [ConstantInfo.name, ConstantInfo.toConstantVal] using
+          TrEnv'.ignore (ci := .defnInfo v) hnMap hvisible (wf.tr (safety := safety))
+    hasPrimitives {safety} := by
+      by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety
+      · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible
+        rw [heq]; exact preserves safety base hvisible hadd
+      · rw [hsame safety hvisible]; exact wf.hasPrimitives (safety := safety)
+    safePrimitives := wf.safePrimitives_add (.defnInfo v) hn hprim
+    mono {safety safety'} hle := by
+      by_cases hvisible' : safety' ≤ (ConstantInfo.defnInfo v).safety
+      · have hvisible := DefinitionSafety.le_trans hle hvisible'
+        obtain ⟨base', hadd', heq'⟩ := hbase safety' hvisible'
+        obtain ⟨base, hadd, heq⟩ := hbase safety hvisible
+        rw [heq', heq]
+        exact VEnv.addDefEq_mono <| VEnv.addConst_mono (wf.mono hle) hadd' hadd
+      rw [hsame safety' hvisible']
+      by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety
+      · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible
+        rw [heq]
+        exact (wf.mono hle).trans <| (VEnv.addConst_le hadd).trans VEnv.addDefEq_le
+      · rw [hsame safety hvisible]; exact wf.mono hle
+    -- Tier V (L4L-19B): checker-readiness transport across this front-end
+    -- extension; see `VEnvAt.addAxioms`.
+    projectionReady {safety} := (readiness safety).1
+    structureEtaReady {safety} := (readiness safety).2 }
+
+/-- The unsafe branch of `addDefinition`. The constant is added to the environment as an axiom
+*before* its body is checked, so the body is translated in the extended environment `base` and
+the whole step is justified by `TrEnv'.mutualDef` with a one-element block.
+
+Unlike `addDef.WF` this cannot conclude `VEnv.AddDef`: that would require the body to translate
+in the environment *before* the addition, which is false for a recursive unsafe definition. -/
+theorem addUnsafeDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (v : DefinitionVal) (ci' : VDefVal) (base : VEnv)
+    (hunsafe : v.safety = .unsafe)
+    (htr : TrConstVal .unsafe (ves.venv .unsafe) (.defnInfo v) ci'.toVConstVal)
+    (hwfc : ci'.toVConstant.WF (ves.venv .unsafe))
+    (hadd : (ves.venv .unsafe).addConst v.name ci'.toVConstant = some base)
+    (hvalue : TrExprS base v.levelParams [] v.value ci'.value)
+    (hci : ci'.WF base)
+    (hn : env.find? v.name = none)
+    (hnonprim : Environment.primitives.contains v.name = false) :
+    ∃ ves' : VEnvs, ves'.WF (env.add (.defnInfo v)) ∧
+      ∀ safety, ves.venv safety ≤ ves'.venv safety := by
+  have hnMap : env.constants.find? v.name = none := by
+    rwa [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?]
+  have hle : ves.venv .unsafe ≤ base.addDefEq ci'.toDefEq :=
+    (VEnv.addConst_le hadd).trans VEnv.addDefEq_le
+  have hname : (ConstantInfo.defnInfo v).name = ci'.name := htr.2
+  have hadd' : (ves.venv .unsafe).addConsts [ci'] = some base := by
+    simp [VEnv.addConsts, ← hname]; exact hadd
+  let ves' : VEnvs := ⟨fun | .unsafe => base.addDefEq ci'.toDefEq | sf => ves.venv sf⟩
+  have readiness : ∀ safety,
+      ProjectionReady (env.add (.defnInfo v)) (ves'.venv safety) ∧
+      StructureEtaReady (env.add (.defnInfo v)) (ves'.venv safety) :=
+    sorry
+  refine ⟨ves', ?_,
+    by rintro ⟨⟩ <;> first | exact hle | exact .rfl⟩
+  exact {
+    tr {safety} := by
+      change TrEnv' safety (env.constants.insert v.name (.defnInfo v)) env.quotInit _
+      match safety with
+      | .unsafe =>
+        have := TrEnv'.mutualDef (safety := .unsafe) (cis := [v]) (cis' := [ci'])
+          (C := env.constants) (Q := env.quotInit) (env := ves.venv .unsafe) (env' := base)
+          (.cons ⟨htr, hvalue⟩ .nil) (by simp) (by simpa using hnMap) (by simpa using hwfc)
+          hadd' (by simpa using hci) wf.tr
+        simpa [insertDefs, VEnv.addDefEqs] using this
+      | .safe | .partial =>
+        refine TrEnv'.ignore (ci := .defnInfo v) hnMap ?_ wf.tr
+        rw [ConstantInfo.defnInfo_safety, hunsafe]; decide
+    hasPrimitives {safety} :=
+      match safety with
+      | .unsafe => ((wf.hasPrimitives (safety := .unsafe)).addConst_of_not_primitive hnonprim hadd).addDefEq
+      | .safe | .partial => wf.hasPrimitives
+    safePrimitives := wf.safePrimitives_add (.defnInfo v) hn
+      (by simp [ConstantInfo.name, ConstantInfo.toConstantVal, hnonprim])
+    mono {safety safety'} hsf :=
+      match safety, safety' with
+      | .unsafe, .unsafe => .rfl
+      | .unsafe, .safe | .unsafe, .partial => (wf.mono hsf).trans hle
+      | .safe, .unsafe | .partial, .unsafe => absurd hsf (by decide)
+      | .safe, .safe | .safe, .partial | .partial, .safe | .partial, .partial => wf.mono hsf
+    -- Tier V (L4L-19B): checker-readiness transport across this front-end
+    -- extension; see `VEnvAt.addAxioms`.
+    projectionReady {safety} := (readiness safety).1
+    structureEtaReady {safety} := (readiness safety).2 }
diff --git a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean
index 30465a28..f963b5e5 100644
--- a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean
+++ b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean
@@ -1604,7 +1604,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.candidateIsDefEqSelfValid' depends on a
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -1628,7 +1627,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depend
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -1653,7 +1651,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindices' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -1677,7 +1674,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindi
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_params' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
diff --git a/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean b/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean
index aeeb3ca7..3a913f38 100644
--- a/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean
+++ b/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean
@@ -919,7 +919,7 @@ theorem nilCandidateInductiveReduceRec
 
 theorem nilCandidateReduceRecursor
     (methods : TypeChecker.Methods) (state : TypeChecker.State) :
-    TypeChecker.Inner.reduceRecursor nilCandidateBody false false
+    TypeChecker.Inner.reduceRecursor nilCandidateBody
       methods (tcContext nilCandidateAlphaLctx) state =
         .ok (none, state) := by
   unfold TypeChecker.Inner.reduceRecursor
@@ -933,14 +933,14 @@ theorem nilCandidateReduceRecursor
 
 @[simp] theorem nilCandidateWhnfCoreFamily (n state) :
     TypeChecker.Inner.whnfCore
-      (.const ``IndexedVec [.param `u]) false false
+      (.const ``IndexedVec [.param `u]) false
       (TypeChecker.Methods.withFuel (n + 1))
       (tcContext nilCandidateAlphaLctx) state =
         .ok (.const ``IndexedVec [.param `u], state) := by
   rfl
 
 theorem nilCandidateWhnfCoreInitial (n : Nat) :
-    TypeChecker.Inner.whnfCore' nilCandidateBody false false
+    TypeChecker.Inner.whnfCore' nilCandidateBody false
       (TypeChecker.Methods.withFuel (n + 1))
       (tcContext nilCandidateAlphaLctx) ({} : TypeChecker.State) =
         .ok (nilCandidateBody, ({} : TypeChecker.State)) := by
@@ -948,7 +948,7 @@ theorem nilCandidateWhnfCoreInitial (n : Nat) :
   change TypeChecker.Inner.whnfCore'
     (.app (.app (.const ``IndexedVec [.param `u])
       (.fvar nilCandidateAlphaId)) (.const ``Nat.zero []))
-    false false (TypeChecker.Methods.withFuel (n + 1))
+    false (TypeChecker.Methods.withFuel (n + 1))
     (tcContext nilCandidateAlphaLctx) ({} : TypeChecker.State) = _
   unfold TypeChecker.Inner.whnfCore'
   simp only [nilRecMPure, nilRecMBind, nilRecMGet,
@@ -1724,7 +1724,7 @@ theorem ctorIndexedVecReduceRecursor
     (lctx : LocalContext) (alpha index : Expr)
     (methods : TypeChecker.Methods) (state : TypeChecker.State) :
     TypeChecker.Inner.reduceRecursor (ctorIndexedVecApp alpha index)
-      false false methods (tcContext lctx) state =
+      methods (tcContext lctx) state =
         .ok (none, state) := by
   unfold TypeChecker.Inner.reduceRecursor
   have hquot : ctorEnv.quotInit = false := by rfl
@@ -1738,7 +1738,7 @@ theorem ctorIndexedVecReduceRecursor
 @[simp] theorem ctorIndexedVecWhnfCoreFamily
     (lctx : LocalContext) (n : Nat) (state : TypeChecker.State) :
     TypeChecker.Inner.whnfCore
-      (.const ``IndexedVec [.param `u]) false false
+      (.const ``IndexedVec [.param `u]) false
       (TypeChecker.Methods.withFuel (n + 1)) (tcContext lctx) state =
         .ok (.const ``IndexedVec [.param `u], state) := by
   rfl
@@ -1746,7 +1746,7 @@ theorem ctorIndexedVecReduceRecursor
 theorem ctorIndexedVecWhnfCoreInitial
     (lctx : LocalContext) (alpha index : Expr) (n : Nat) :
     TypeChecker.Inner.whnfCore' (ctorIndexedVecApp alpha index)
-      false false (TypeChecker.Methods.withFuel (n + 1))
+      false (TypeChecker.Methods.withFuel (n + 1))
       (tcContext lctx) ({} : TypeChecker.State) =
         .ok (ctorIndexedVecApp alpha index, ({} : TypeChecker.State)) := by
   unfold ctorIndexedVecApp TypeChecker.Inner.whnfCore'
diff --git a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean
index 4cd4666b..7e324643 100644
--- a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean
+++ b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean
@@ -1,4 +1,5 @@
 import Lean4Lean.Verify.Environment.IndexedVecConsReplay
+import Lean4Lean.Verify.Name
 
 /-!
 # IndexedVec outer normalization-candidate replay
@@ -1320,13 +1321,13 @@ theorem indexedVecValidationConsLoopTail :
   simp only [ReaderT.bind, Bind.bind]
   rw [AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationTailEnsureTypeM]
-  simp only [Except.bind, Expr.sortLevel!]
-  rw [show AddInductive.levelStructGe
+  simp only [Except.bind]
+  rw [if_pos (show AddInductive.levelStructGe
       indexedVecCandidateInductiveStats.resultLevel
-      (.succ (.param `u)) = true by
-    simp [indexedVecCandidateInductiveStats_resultLevel,
-      AddInductive.levelStructGe, AddInductive.levelStructEq]]
-  simp only [if_true, Bool.not_false,
+      (Expr.sort (.succ (.param `u))).sortLevel! = true from by
+    simp [Expr.sortLevel!, indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe, AddInductive.levelStructEq])]
+  simp only [↓reduceIte, Bool.not_false,
     ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
     Except.bind, Except.pure]
   rw [indexedVecValidationTailPositivity]
@@ -1357,13 +1358,13 @@ theorem indexedVecValidationConsLoopHead :
   simp only [ReaderT.bind, Bind.bind]
   rw [AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationAlphaEnsureTypeM]
-  simp only [Except.bind, Expr.sortLevel!]
-  rw [show AddInductive.levelStructGe
+  simp only [Except.bind]
+  rw [if_pos (show AddInductive.levelStructGe
       indexedVecCandidateInductiveStats.resultLevel
-      (.succ (.param `u)) = true by
-    simp [indexedVecCandidateInductiveStats_resultLevel,
-      AddInductive.levelStructGe, AddInductive.levelStructEq]]
-  simp only [if_true, Bool.not_false,
+      (Expr.sort (.succ (.param `u))).sortLevel! = true from by
+    simp [Expr.sortLevel!, indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe, AddInductive.levelStructEq])]
+  simp only [↓reduceIte, Bool.not_false,
     ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
     Except.bind, Except.pure]
   rw [indexedVecValidationAlphaPositivity]
@@ -1400,13 +1401,13 @@ theorem indexedVecValidationConsLoopN :
   simp only [ReaderT.bind, Bind.bind]
   rw [AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationNatEnsureTypeM]
-  simp only [Except.bind, Expr.sortLevel!]
-  rw [show AddInductive.levelStructGe
-      indexedVecCandidateInductiveStats.resultLevel (.succ .zero) =
-      true by
-    simp [indexedVecCandidateInductiveStats_resultLevel,
-      AddInductive.levelStructGe]]
-  simp only [if_true, Bool.not_false,
+  simp only [Except.bind]
+  rw [if_pos (show AddInductive.levelStructGe
+      indexedVecCandidateInductiveStats.resultLevel
+      (Expr.sort (.succ .zero)).sortLevel! = true from by
+    simp [Expr.sortLevel!, indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe])]
+  simp only [↓reduceIte, Bool.not_false,
     ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
     Except.bind, Except.pure]
   rw [indexedVecValidationNatPositivity]
@@ -1507,11 +1508,12 @@ theorem indexedVecValidationConsUniverseLoopTail :
   simp only [ReaderT.bind, Bind.bind, AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationTailEnsureTypeM]
   simp only [Except.bind]
-  simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
-    indexedVecCandidateInductiveStats_resultLevel,
-    AddInductive.levelStructGe, AddInductive.levelStructEq, Pure.pure]
-  simp only [ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
-    Except.pure, Except.bind]
+  rw [if_pos (show AddInductive.constructorUniverseSemanticGe
+      indexedVecCandidateInductiveStats.resultLevel
+      (Expr.sort (.succ (.param `u))).sortLevel! = true from by
+    simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
+      indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe, AddInductive.levelStructEq])]
   rw [AddInductive.withLocalDecl_apply]
   simpa [indexedVecValidationTailContext,
     AddInductive.Context.pushLocalDecl,
@@ -1533,11 +1535,12 @@ theorem indexedVecValidationConsUniverseLoopHead :
   simp only [ReaderT.bind, Bind.bind, AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationAlphaEnsureTypeM]
   simp only [Except.bind]
-  simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
-    indexedVecCandidateInductiveStats_resultLevel,
-    AddInductive.levelStructGe, AddInductive.levelStructEq, Pure.pure]
-  simp only [ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
-    Except.pure, Except.bind]
+  rw [if_pos (show AddInductive.constructorUniverseSemanticGe
+      indexedVecCandidateInductiveStats.resultLevel
+      (Expr.sort (.succ (.param `u))).sortLevel! = true from by
+    simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
+      indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe, AddInductive.levelStructEq])]
   rw [AddInductive.withLocalDecl_apply]
   simpa [indexedVecValidationHeadContext,
     AddInductive.Context.pushLocalDecl,
@@ -1560,11 +1563,12 @@ theorem indexedVecValidationConsUniverseLoopN :
   simp only [ReaderT.bind, Bind.bind, AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationNatEnsureTypeM]
   simp only [Except.bind]
-  simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
-    indexedVecCandidateInductiveStats_resultLevel,
-    AddInductive.levelStructGe, Pure.pure]
-  simp only [ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind,
-    Except.pure, Except.bind]
+  rw [if_pos (show AddInductive.constructorUniverseSemanticGe
+      indexedVecCandidateInductiveStats.resultLevel
+      (Expr.sort (.succ .zero)).sortLevel! = true from by
+    simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe,
+      indexedVecCandidateInductiveStats_resultLevel,
+      AddInductive.levelStructGe])]
   rw [AddInductive.withLocalDecl_apply]
   simpa [indexedVecValidationNContext,
     AddInductive.Context.pushLocalDecl,
@@ -1643,10 +1647,12 @@ theorem indexedVecValidationEmptyDoesNotContainNil :
 theorem indexedVecValidationNilSetDoesNotContainCons :
     ((∅ : NameSet).insert indexedVecKernelNil.name).contains
       indexedVecKernelCons.name = false := by
-  simp +decide [indexedVecKernelNil, indexedVecKernelCons,
+  simp only [indexedVecKernelNil, indexedVecKernelCons,
     indexedVecNilInfo, indexedVecConsInfo,
-    ConstantInfo.name, NameSet.contains, NameSet.insert,
-    Std.TreeSet.contains_insert]
+    ConstantInfo.name, ConstantInfo.toConstantVal,
+    NameSet.contains, NameSet.insert]
+  rw [Std.TreeSet.contains_insert (t := (∅ : NameSet))]
+  simp +decide [beq_iff_eq, Std.LawfulBEqCmp.compare_eq_iff_beq]
 
 set_option linter.unusedSimpArgs false in
 theorem indexedVecValidationCheckConstructors :
@@ -1658,14 +1664,9 @@ theorem indexedVecValidationCheckConstructors :
   rw [AddInductive.liftTypeChecker_apply]
   rw [indexedVecValidationGetEnvM]
   simp only [Except.bind]
-  unfold AddInductive.checkConstructorFold
-  simp only [indexedVecKernelType,
-    Std.Legacy.Range.forIn'_eq_forIn'_range', Std.Legacy.Range.size,
-    List.range', List.forIn'_cons, List.forIn'_nil,
-    List.forIn_cons, List.forIn_nil,
-    List.size_toArray, List.length_cons, List.length_nil,
-    List.getElem_toArray, List.getElem_cons_zero,
-    Nat.sub_zero, Nat.zero_add, Nat.add_sub_cancel, Nat.div_one]
+  unfold AddInductive.checkConstructorsLoop AddInductive.checkConstructorFold
+  simp only [indexedVecKernelType, List.toList_toArray,
+    ReaderT.bind, Bind.bind, Except.bind]
   rw [indexedVecValidationEmptyDoesNotContainNil]
   simp only [Bool.false_eq_true, if_false,
     ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
@@ -1739,7 +1740,6 @@ theorem indexedVecNormalizationCandidateProduced :
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecNormalizationCandidateProduced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean
index b7eeac2a..a16e5f42 100644
--- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean
+++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean
@@ -103,6 +103,224 @@ theorem indexedVecSemanticNatSafePrimitives :
           exact ⟨rfl, rfl⟩
         · simp [SMap.find?] at hfind
 
+theorem indexedVecKernelEnv_noProjectionReady (name : Name) :
+    indexedVecKernelEnv.isProjectionReadyStructure name = false := by
+  simp only [indexedVecKernelEnv,
+    Kernel.Environment.isProjectionReadyStructure,
+    Kernel.Environment.ofConstants]
+  simp only [natMap_wf.find?'_eq_find?]
+  simp only [natMap, natCtorMap_wf.find?_insert]
+  simp only [natCtorMap, natZeroMap_wf.find?_insert]
+  simp only [natZeroMap, natTypeMap_wf.find?_insert]
+  simp only [natTypeMap, SMap.WF.find?_insert
+    (s := ({} : ConstMap)) SMap.WF.empty]
+  by_cases hRec : ``Nat.rec = name
+  · subst name
+    simp [SMap.find?, natRecInfo]
+  · by_cases hSucc : ``Nat.succ = name
+    · subst name
+      simp [hRec, SMap.find?, natSuccInfo]
+    · by_cases hZero : ``Nat.zero = name
+      · subst name
+        simp [hRec, hSucc, SMap.find?, natZeroInfo]
+      · by_cases hNat : ``Nat = name
+        · subst name
+          simp [hRec, hSucc, hZero, SMap.find?, natInfo]
+        · simp [hRec, hSucc, hZero, hNat, SMap.find?]
+
+theorem indexedVecKernelEnv_noStructureEta (name : Name) :
+    indexedVecKernelEnv.isNonRecStructure name = false := by
+  simp only [indexedVecKernelEnv, Kernel.Environment.isNonRecStructure,
+    Kernel.Environment.ofConstants, Kernel.Environment.find?]
+  simp only [natMap_wf.find?'_eq_find?]
+  simp only [natMap, natCtorMap_wf.find?_insert]
+  simp only [natCtorMap, natZeroMap_wf.find?_insert]
+  simp only [natZeroMap, natTypeMap_wf.find?_insert]
+  simp only [natTypeMap, SMap.WF.find?_insert
+    (s := ({} : ConstMap)) SMap.WF.empty]
+  by_cases hRec : ``Nat.rec = name
+  · subst name
+    simp [SMap.find?, natRecInfo]
+  · by_cases hSucc : ``Nat.succ = name
+    · subst name
+      simp [hRec, SMap.find?, natSuccInfo]
+    · by_cases hZero : ``Nat.zero = name
+      · subst name
+        simp [hRec, hSucc, SMap.find?, natZeroInfo]
+      · by_cases hNat : ``Nat = name
+        · subst name
+          simp [hRec, hSucc, hZero, SMap.find?, natInfo]
+        · simp [hRec, hSucc, hZero, hNat, SMap.find?]
+
+theorem indexedVecTypeEnv_noProjectionReady (name : Name) :
+    ctorContext.env.isProjectionReadyStructure name = false := by
+  simp only [ctorContext, ctorEnv,
+    Kernel.Environment.isProjectionReadyStructure,
+    Kernel.Environment.ofConstants]
+  simp only [indexedVecTypeMap_wf.find?'_eq_find?]
+  simp only [indexedVecTypeMap, natMap_wf.find?_insert]
+  simp only [natMap, natCtorMap_wf.find?_insert]
+  simp only [natCtorMap, natZeroMap_wf.find?_insert]
+  simp only [natZeroMap, natTypeMap_wf.find?_insert]
+  simp only [natTypeMap, SMap.WF.find?_insert
+    (s := ({} : ConstMap)) SMap.WF.empty]
+  by_cases hVec : ``IndexedVec = name
+  · subst name
+    simp [SMap.find?, indexedVecInfo]
+  · by_cases hRec : ``Nat.rec = name
+    · subst name
+      simp [hVec, SMap.find?, natRecInfo]
+    · by_cases hSucc : ``Nat.succ = name
+      · subst name
+        simp [hVec, hRec, SMap.find?, natSuccInfo]
+      · by_cases hZero : ``Nat.zero = name
+        · subst name
+          simp [hVec, hRec, hSucc, SMap.find?, natZeroInfo]
+        · by_cases hNat : ``Nat = name
+          · subst name
+            simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo]
+          · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?]
+
+theorem indexedVecTypeEnv_noStructureEta (name : Name) :
+    ctorContext.env.isNonRecStructure name = false := by
+  simp only [ctorContext, ctorEnv, Kernel.Environment.isNonRecStructure,
+    Kernel.Environment.ofConstants, Kernel.Environment.find?]
+  simp only [indexedVecTypeMap_wf.find?'_eq_find?]
+  simp only [indexedVecTypeMap, natMap_wf.find?_insert]
+  simp only [natMap, natCtorMap_wf.find?_insert]
+  simp only [natCtorMap, natZeroMap_wf.find?_insert]
+  simp only [natZeroMap, natTypeMap_wf.find?_insert]
+  simp only [natTypeMap, SMap.WF.find?_insert
+    (s := ({} : ConstMap)) SMap.WF.empty]
+  by_cases hVec : ``IndexedVec = name
+  · subst name
+    simp [SMap.find?, indexedVecInfo]
+  · by_cases hRec : ``Nat.rec = name
+    · subst name
+      simp [hVec, SMap.find?, natRecInfo]
+    · by_cases hSucc : ``Nat.succ = name
+      · subst name
+        simp [hVec, hRec, SMap.find?, natSuccInfo]
+      · by_cases hZero : ``Nat.zero = name
+        · subst name
+          simp [hVec, hRec, hSucc, SMap.find?, natZeroInfo]
+        · by_cases hNat : ``Nat = name
+          · subst name
+            simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo]
+          · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?]
+
+private theorem addConst_constants {env env' : VEnv} {name : Name}
+    {ci : VConstant} (hadd : env.addConst name ci = some env') (query : Name) :
+    env'.constants query =
+      if name = query then some ci else env.constants query := by
+  unfold VEnv.addConst at hadd
+  split at hadd <;> cases hadd
+  rfl
+
+private theorem structureView_nparams_eq_zero_of_nat
+    {env : VEnv} {view : VStructureView} (hview : view.WF env)
+    (hname : ``Nat = view.name)
+    (hNat : env.constants ``Nat = some natType.toVConstant) :
+    view.nparams = 0 := by
+  have hfamily := hview.family
+  rw [← hname, hNat] at hfamily
+  have hsourceType : view.generation.block.sourceType.type = natType.type :=
+    congrArg VConstant.type (Option.some.inj hfamily).symm
+  have hshape := view.generation.shape_eq
+  simp only [VInductDecl.NormalizedChecked.generationShape, Bool.and_eq_true,
+    beq_iff_eq] at hshape
+  have hrawParamsLength := hshape.1.1.1.1.1
+  have hNatType : natType.type = .sort (.succ .zero) := rfl
+  rw [VInductDecl.NormalizedChecked.rawParams, hsourceType,
+    hNatType] at hrawParamsLength
+  cases hnp : view.source.nparams with
+  | zero => simpa using hnp
+  | succ _ =>
+    rw [hnp] at hrawParamsLength
+    simp [VExpr.telN] at hrawParamsLength
+
+private theorem natFinalEnv_structureView_nparams_eq_zero
+    {view : VStructureView} (hview : view.WF natFinalEnv) :
+    view.nparams = 0 := by
+  have hrec := hview.recursor
+  change natRecEnv.constants view.recursorName =
+    some view.generation.recursor at hrec
+  rw [addConst_constants
+      (show natCtorEnv.addConst ``Nat.rec
+        (VInductDecl.recConst 0 ``Nat 0 natType) = some natRecEnv from rfl),
+    addConst_constants
+      (show natZeroEnv.addConst natType.ctors[1].name
+        natType.ctors[1].toVConstant = some natCtorEnv from rfl),
+    addConst_constants
+      (show natTypeEnv.addConst natType.ctors[0].name
+        natType.ctors[0].toVConstant = some natZeroEnv from rfl),
+    addConst_constants
+      (show VEnv.empty.addConst natType.name natType.toVConstant =
+        some natTypeEnv from rfl)] at hrec
+  have hNatName : natType.name = ``Nat := rfl
+  have hZeroName : natType.ctors[0].name = ``Nat.zero := rfl
+  have hSuccName : natType.ctors[1].name = ``Nat.succ := rfl
+  rw [hNatName, hZeroName, hSuccName] at hrec
+  simp [VEnv.empty, VStructureView.recursorName] at hrec
+  exact structureView_nparams_eq_zero_of_nat hview hrec.1
+    nat_type_env_lookup
+
+private theorem indexedVecTypeEnv_structureView_nparams_eq_zero
+    {view : VStructureView} (hview : view.WF indexedVecTypeEnv) :
+    view.nparams = 0 := by
+  have hrec := hview.recursor
+  rw [addConst_constants
+      (show natFinalEnv.addConst indexedVecType.name
+        indexedVecType.toVConstant = some indexedVecTypeEnv from rfl)] at hrec
+  change (if indexedVecType.name = view.recursorName then
+      some indexedVecType.toVConstant else
+      natRecEnv.constants view.recursorName) =
+    some view.generation.recursor at hrec
+  rw [addConst_constants
+      (show natCtorEnv.addConst ``Nat.rec
+        (VInductDecl.recConst 0 ``Nat 0 natType) = some natRecEnv from rfl),
+    addConst_constants
+      (show natZeroEnv.addConst natType.ctors[1].name
+        natType.ctors[1].toVConstant = some natCtorEnv from rfl),
+    addConst_constants
+      (show natTypeEnv.addConst natType.ctors[0].name
+        natType.ctors[0].toVConstant = some natZeroEnv from rfl),
+    addConst_constants
+      (show VEnv.empty.addConst natType.name natType.toVConstant =
+        some natTypeEnv from rfl)] at hrec
+  have hVecName : indexedVecType.name = ``IndexedVec := rfl
+  have hNatName : natType.name = ``Nat := rfl
+  have hZeroName : natType.ctors[0].name = ``Nat.zero := rfl
+  have hSuccName : natType.ctors[1].name = ``Nat.succ := rfl
+  rw [hVecName, hNatName, hZeroName, hSuccName] at hrec
+  simp [VEnv.empty, VStructureView.recursorName] at hrec
+  exact structureView_nparams_eq_zero_of_nat hview hrec.1 rfl
+
+private theorem natMap_constructor_numParams
+    {view : VStructureView} {info : ConstructorVal}
+    (hzero : view.nparams = 0)
+    (hfind : natMap.find? view.constructorName = some (.ctorInfo info)) :
+    info.numParams = view.nparams := by
+  rw [natMap, natCtorMap_wf.find?_insert] at hfind
+  split at hfind
+  · cases hfind
+  · rw [natCtorMap, natZeroMap_wf.find?_insert] at hfind
+    split at hfind
+    · simp [natSuccInfo] at hfind
+      cases hfind
+      exact hzero.symm
+    · rw [natZeroMap, natTypeMap_wf.find?_insert] at hfind
+      split at hfind
+      · simp [natZeroInfo] at hfind
+        cases hfind
+        exact hzero.symm
+      · rw [natTypeMap,
+          SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+          at hfind
+        split at hfind
+        · cases hfind
+        · simp [SMap.find?] at hfind
+
 def indexedVecSemanticNatVEnvs : VEnvs where
   venv _ := natFinalEnv
 
@@ -110,10 +328,24 @@ theorem indexedVecSemanticNatVEnvsWF : indexedVecSemanticNatVEnvs.WF indexedVecK
   tr := by
     intro safety
     change TrEnv' _ natMap false natFinalEnv
-    exact nat_trEnv'.sf_mono DefinitionSafety.le_safe
+    exact nat_trEnv'
   hasPrimitives := indexedVecSemanticNatHasPrimitives
   safePrimitives := indexedVecSemanticNatSafePrimitives
   mono := fun _ => .rfl
+  projectionReady := {
+    infer := by
+      intro name _info _hfind hready
+      rw [indexedVecKernelEnv_noProjectionReady] at hready
+      contradiction
+    constructorNumParams := by
+      intro view info hview hfind
+      change natMap.find?' view.constructorName =
+        some (.ctorInfo info) at hfind
+      rw [natMap_wf.find?'_eq_find?] at hfind
+      exact natMap_constructor_numParams
+        (natFinalEnv_structureView_nparams_eq_zero hview) hfind }
+  structureEtaReady := StructureEtaReady.of_no_nonRecStructure
+    indexedVecKernelEnv_noStructureEta
 
 def indexedVecSemanticAddType :
     AddInductConstant .induct natMap natFinalEnv
@@ -172,6 +404,23 @@ def indexedVecFamilyStage :
   validation := indexedVecFamilyValidationRun
   typeEnv := indexedVecTypeEnv
   addInduct := indexedVecSemanticAddType
+  projectionReady := {
+    infer := by
+      intro name _info _hfind hready
+      rw [indexedVecTypeEnv_noProjectionReady] at hready
+      contradiction
+    constructorNumParams := by
+      intro view info hview hfind
+      change indexedVecTypeMap.find?' view.constructorName =
+        some (.ctorInfo info) at hfind
+      rw [indexedVecTypeMap_wf.find?'_eq_find?, indexedVecTypeMap,
+        natMap_wf.find?_insert] at hfind
+      split at hfind
+      · cases hfind
+      · exact natMap_constructor_numParams
+          (indexedVecTypeEnv_structureView_nparams_eq_zero hview) hfind }
+  structureEtaReady := StructureEtaReady.of_no_nonRecStructure
+    indexedVecTypeEnv_noStructureEta
   family_lctx_eq := rfl
   constructorContext_eq := rfl
   quotInit_eq := rfl
@@ -213,7 +462,7 @@ theorem indexedVecSemanticConsSourceTr :
   exact hshape.to_trExprS indexedVecTypeEnv_ordered trivial
     ⟨.sort u, htype⟩
 
-noncomputable def indexedVecStagedUniverseInput :
+def indexedVecStagedUniverseInput :
     VInductDecl.StagedNormalizationCandidateUniverseInput
       indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u]
       indexedVecNormalizationCandidate indexedVecDecl where
@@ -786,7 +1035,7 @@ private theorem indexedVecCandidateWhnfResult_eq
   rw [self] at other
   exact (Except.ok.inj other).symm
 
-private noncomputable def indexedVecValidationNatPositivityAlignment
+private def indexedVecValidationNatPositivityAlignment
     (trace : AddInductive.ConstructorPositivityModeTrace
       indexedVecStagedUniverseInput.staged.family.validation.stats false
       indexedVecKernelCons.name 1 indexedVecCtorValidationContext
@@ -816,7 +1065,7 @@ private noncomputable def indexedVecValidationNatPositivityAlignment
             indexedVecValidationNatHasNoIndOcc] at occurs
           contradiction
 
-private noncomputable def indexedVecValidationAlphaPositivityAlignment
+private def indexedVecValidationAlphaPositivityAlignment
     (trace : AddInductive.ConstructorPositivityModeTrace
       indexedVecStagedUniverseInput.staged.family.validation.stats false
       indexedVecKernelCons.name 2 indexedVecValidationNContext
@@ -849,7 +1098,7 @@ private noncomputable def indexedVecValidationAlphaPositivityAlignment
           rw [indexedVecValidationAlphaHasNoIndOcc] at occurs
           contradiction
 
-private noncomputable def indexedVecValidationTailPositivityAlignment
+private def indexedVecValidationTailPositivityAlignment
     (trace : AddInductive.ConstructorPositivityModeTrace
       indexedVecStagedUniverseInput.staged.family.validation.stats false
       indexedVecKernelCons.name 3 indexedVecValidationHeadContext
@@ -926,7 +1175,7 @@ theorem indexedVecValidationCandidateFieldFVars_ne :
 /-- Exact D2 owner for `IndexedVec`.  Its validator telescope is transported
 only across proved context/source equalities, while every candidate view is
 instantiated with the validator-owned locals at the same de Bruijn position. -/
-noncomputable def indexedVecStagedPostFamilyInput :
+def indexedVecStagedPostFamilyInput :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput
       indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u]
       indexedVecNormalizationCandidate indexedVecDecl where
@@ -2595,7 +2844,7 @@ private theorem indexedVecPreFamilySafetyRun :
   rw [constructorListRun]
   rfl
 
-private noncomputable def indexedVecStagedPreFamilyInput :
+private def indexedVecStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u]
       indexedVecNormalizationCandidate indexedVecDecl :=
@@ -2862,31 +3111,32 @@ theorem indexedVecSemanticExactProducedGenerationCandidatePackage_exists :
     |>.exactProducedPackage_nonempty indexedVecStagedPreFamilyInput rfl
       indexedVecChecked.identityGeneration indexedVecSemanticCandidate_analysis
 
-private noncomputable def
+private def
     indexedVecSemanticExactProducedGenerationCandidatePackage :
     VInductDecl.ExactProducedGenerationCandidatePackage natFinalEnv [`u]
       indexedVecSemanticProducedGenerationShapeCandidate
       indexedVecChecked.identityGeneration :=
-  Classical.choice
-    indexedVecSemanticExactProducedGenerationCandidatePackage_exists
+  indexedVecSemanticProducedGenerationShapeCandidate.exactProducedPackage
+    indexedVecStagedPreFamilyInput rfl indexedVecChecked.identityGeneration
+    indexedVecSemanticCandidate_analysis
 
-noncomputable def indexedVecSemanticGenerationCandidateSemanticRun :
+def indexedVecSemanticGenerationCandidateSemanticRun :
   VInductDecl.GenerationCandidateSemanticRun
       indexedVecSemanticExactProducedGenerationCandidatePackage.normalization
       indexedVecChecked.identityGeneration :=
   indexedVecSemanticExactProducedGenerationCandidatePackage.semantic
 
-noncomputable def indexedVecSemanticGenerationCandidateRun :
+def indexedVecSemanticGenerationCandidateRun :
     VInductDecl.GenerationCandidateRun
       indexedVecSemanticExactProducedGenerationCandidatePackage.normalization.root
       indexedVecChecked.identityGeneration :=
   indexedVecSemanticGenerationCandidateSemanticRun.run
 
-noncomputable def indexedVecSemanticGenerationCandidatePackage :
+def indexedVecSemanticGenerationCandidatePackage :
     VInductDecl.GenerationCandidatePackage natFinalEnv [`u] :=
   indexedVecSemanticGenerationCandidateSemanticRun.package
 
-noncomputable def indexedVecSemanticProducedGenerationCandidatePackage :
+def indexedVecSemanticProducedGenerationCandidatePackage :
     VInductDecl.ProducedGenerationCandidatePackage natFinalEnv [`u] :=
   indexedVecSemanticExactProducedGenerationCandidatePackage.package
 
@@ -2911,7 +3161,7 @@ theorem indexedVecSemanticCertified_ordered :
   VEnv.addInductCertified_WF nat_env_wf.ordered
     indexedVecSemantic_addInductCertified
 
-noncomputable def indexedVecSemanticAddInductTraceChecked :
+def indexedVecSemanticAddInductTraceChecked :
     AddInductTrace natMap natFinalEnv indexedVecDecl indexedVecMap
       indexedVecFinalEnv := by
   refine indexedVecSemanticProducedGenerationCandidatePackage.package.addInductTrace
@@ -3004,9 +3254,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedSemanticHierarchy_exi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3037,9 +3290,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedPostFamilySemantic_ex
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3070,9 +3326,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedPreFamilySemantic_exi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3103,9 +3362,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedSemanticHierarchy_con
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3120,7 +3382,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecReorderedView_rejected' depen
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticCandidate_missingRawShape_rejected' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -3152,7 +3413,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticCandidate_extraRawSha
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationShapeCandidate_produced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -3200,9 +3460,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticExactProducedGenerati
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3233,9 +3496,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationCandidateSe
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3266,9 +3532,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticProducedGenerationCan
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -3299,9 +3568,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemantic_trEnv'_checked' depe
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean
index 330016e2..38a1d312 100644
--- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean
+++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean
@@ -153,16 +153,14 @@ theorem natDecl_wf : natDecl.WF VEnv.empty := by
   · constructor
     · change True
       trivial
-    · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-      rfl
+    · exact .nil
   · have hc' := List.mem_singleton.1 hc
     subst c
     constructor
     · refine ⟨.inl rfl, ?_, trivial⟩
       intro
-      rfl
-    · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-      rfl
+      exact .nil
+    · exact .nil
 
 /-- The exact intermediate invariant used to type the generated recursor. -/
 theorem natStage3 :
@@ -207,15 +205,13 @@ theorem natStage3 :
       subst c
       refine ⟨.inl rfl, ?_, trivial⟩
       intro
-      rfl
+      exact .nil
   · intro c hc
     rcases List.mem_cons.1 hc with rfl | hc
-    · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-      rfl
+    · exact .nil
     · have hc' := List.mem_singleton.1 hc
       subst c
-      change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-      rfl
+      exact .nil
 
 theorem natInfo_tr :
     TrConstVal .safe VEnv.empty natInfo natType.toVConstVal := by
@@ -345,16 +341,16 @@ theorem nat_addInduct :
 
 /-- The formerly impossible `TrEnv'.induct` branch, instantiated with a real
 Lean declaration transaction. -/
-theorem nat_trEnv' : TrEnv' .safe natMap false natFinalEnv :=
+theorem nat_trEnv' {safety : DefinitionSafety} :
+    TrEnv' safety natMap false natFinalEnv :=
   .induct nat_addInduct .empty
 
 theorem nat_final_matches_addInduct :
     VEnv.empty.addInduct natDecl = some natFinalEnv :=
   rfl
 
-/-- Theory-only ordering evidence for the Nat dependency environment.  This
-keeps later inductive preservation proofs independent of the Verify relation's
-known projection-sorry frontier. -/
+/-- Theory-only ordering evidence for the Nat dependency environment. This
+keeps later inductive preservation proofs entirely within the Theory layer. -/
 theorem natFinalEnv_ordered : natFinalEnv.Ordered :=
   VEnv.addInductGeneration_WF .empty
     ((natChecked.wf_of_decl natDecl_wf).identityGeneration .empty) rfl
@@ -365,9 +361,9 @@ info: 'Lean4Lean.InductiveReplayFixtures.natFinalEnv_ordered' depends on axioms:
 #guard_msgs in
 #print axioms natFinalEnv_ordered
 
-theorem nat_env_wf : natFinalEnv.WF := nat_trEnv'.wf
+theorem nat_env_wf : natFinalEnv.WF := (nat_trEnv' (safety := .safe)).wf
 
-theorem nat_aligned : Aligned .safe natMap natFinalEnv := nat_trEnv'.aligned
+theorem nat_aligned : Aligned .safe natMap natFinalEnv := (nat_trEnv' (safety := .safe)).aligned
 
 theorem nat_type_map_lookup : natMap.find? ``Nat = some natInfo := by
   rw [natMap, natCtorMap_wf.find?_insert, natCtorMap,
@@ -412,12 +408,10 @@ theorem nat_rec_lookup_unique :
         (VInductDecl.recConst 0 ``Nat 0 natType) :=
   nat_aligned.find?_uniq nat_rec_map_lookup nat_rec_env_lookup
 
-/- This closure is transitional for exactly the reasons recorded in the
-roadmap: `sorryAx` comes from `TrProj`, and the persistent-map contracts come
+/- This closure is now free of `sorryAx`; the persistent-map contracts come
 from proving concrete `SMap` freshness. The fixture introduces no new axiom. -/
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.nat_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -637,7 +631,6 @@ theorem seed_after_nat_of_value :
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.seed_after_nat_of_value' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -699,8 +692,7 @@ theorem eqDecl_wf : eqDecl.WF VEnv.empty := by
     constructor
     · change True
       trivial
-    · refine ⟨_, _, rfl, ?_, rfl⟩
-      type_tac
+    · exact .cons (by type_tac) .nil
 
 theorem eqRefl_wf : eqType.ctors[0].toVConstant.WF eqTypeEnv := by
   have hblock := eqDecl_wf.2 eqType (by simp [eqDecl])
@@ -918,7 +910,6 @@ theorem eq_rec_lookup_unique :
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.eq_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -998,8 +989,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by
         have hNat : natFinalEnv.constants ``Nat = some natType.toVConstant := rfl
         have hZero : natFinalEnv.constants ``Nat.zero =
             some natType.ctors[0].toVConstant := rfl
-        exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-          (by type_tac), rfl⟩
+        exact .cons (by type_tac) .nil
     · have hc' := List.mem_singleton.1 hc
       subst c
       constructor
@@ -1026,8 +1016,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by
         · exact .inl rfl
         constructor
         · intro _
-          exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-            (by type_tac), rfl⟩
+          exact .cons (by type_tac) .nil
         · trivial
       · change natFinalEnv.SpineWF 1
           [VExpr.app (VExpr.app (VExpr.const ``IndexedVec [VLevel.param 0])
@@ -1041,8 +1030,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by
         have hNat : natFinalEnv.constants ``Nat = some natType.toVConstant := rfl
         have hSucc : natFinalEnv.constants ``Nat.succ =
             some natType.ctors[1].toVConstant := rfl
-        exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-          (by type_tac), rfl⟩
+        exact .cons (by type_tac) .nil
 
 theorem natFinalEnv_le_indexedVecTypeEnv : natFinalEnv ≤ indexedVecTypeEnv :=
   VEnv.addConst_le (show natFinalEnv.addConst indexedVecType.name
@@ -1264,7 +1252,7 @@ def indexedVecFinalEnv : VEnv :=
   (VInductDecl.rules 1 ``IndexedVec 1 indexedVecType).foldl
     VEnv.addDefEq indexedVecRecEnv
 
-theorem natMap_wf : natMap.WF := nat_trEnv'.map_wf
+theorem natMap_wf : natMap.WF := (nat_trEnv' (safety := .safe)).map_wf
 
 theorem indexedVecType_fresh : natMap.find? ``IndexedVec = none := by
   rw [natMap, natCtorMap_wf.find?_insert, natCtorMap,
@@ -1431,7 +1419,6 @@ theorem indexedVec_rec_lookup_unique :
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -1721,12 +1708,10 @@ theorem acc_rec_lookup_unique :
         (VInductDecl.recConstRec 1 ``Acc 2 accType) :=
   acc_aligned.find?_uniq acc_rec_map_lookup acc_rec_env_lookup
 
-/- This has the same transitional Verify closure as the direct replay roots:
-`sorryAx` enters through `TrProj`, and the persistent-map contracts enter
-through concrete `SMap` freshness proofs. -/
+/- This has the same `sorryAx`-free closure as the direct replay roots; the
+persistent-map contracts enter through concrete `SMap` freshness proofs. -/
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.acc_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -1770,10 +1755,11 @@ theorem typeFamilyAliasMap_fresh :
   simp [SMap.find?]
 
 /-- Replay the actual alias definition, including its Theory delta rule. -/
-theorem typeFamilyAlias_trEnv' :
-    TrEnv' .safe typeFamilyAliasMap false typeFamilyAliasEnv :=
+theorem typeFamilyAlias_trEnv' {safety : DefinitionSafety} :
+    TrEnv' safety typeFamilyAliasMap false typeFamilyAliasEnv :=
   .defn (ci := typeFamilyAliasKernelDef) (ci' := typeFamilyAliasVal)
-    typeFamilyAliasInfo_tr typeFamilyAliasMap_fresh
+    (typeFamilyAliasInfo_tr.sf_mono DefinitionSafety.le_safe)
+    typeFamilyAliasMap_fresh
     typeFamilyAliasVal_wf rfl .empty
 
 def aliasFormerInfo : ConstantInfo := kernelInductInfo% AliasFormer
@@ -1912,7 +1898,7 @@ def aliasFormerMap : ConstMap :=
   aliasFormerCtorMap.insert ``AliasFormer.rec aliasFormerRecInfo
 
 theorem typeFamilyAliasMap_wf : typeFamilyAliasMap.WF :=
-  typeFamilyAlias_trEnv'.map_wf
+  (typeFamilyAlias_trEnv' (safety := .safe)).map_wf
 
 theorem aliasFormerType_fresh :
     typeFamilyAliasMap.find? ``AliasFormer = none := by
@@ -2079,10 +2065,11 @@ theorem recAliasMap_fresh :
     ({} : ConstMap).find? ``RecAlias = none := by
   simp [SMap.find?]
 
-theorem recAlias_trEnv' :
-    TrEnv' .safe recAliasMap false recAliasEnv :=
+theorem recAlias_trEnv' {safety : DefinitionSafety} :
+    TrEnv' safety recAliasMap false recAliasEnv :=
   .defn (ci := recAliasKernelDef) (ci' := recAliasVal)
-    recAliasInfo_tr recAliasMap_fresh recAliasVal_wf rfl .empty
+    (recAliasInfo_tr.sf_mono DefinitionSafety.le_safe)
+    recAliasMap_fresh recAliasVal_wf rfl .empty
 
 def aliasRecInfo : ConstantInfo := kernelInductInfo% AliasRec
 def aliasRecMkInfo : ConstantInfo := kernelCtorInfo% AliasRec.mk
@@ -2219,7 +2206,7 @@ def aliasRecCtorMap : ConstMap :=
 def aliasRecMap : ConstMap :=
   aliasRecCtorMap.insert ``AliasRec.rec aliasRecRecInfo
 
-theorem recAliasMap_wf : recAliasMap.WF := recAlias_trEnv'.map_wf
+theorem recAliasMap_wf : recAliasMap.WF := (recAlias_trEnv' (safety := .safe)).map_wf
 
 theorem aliasRecType_fresh :
     recAliasMap.find? ``AliasRec = none := by
@@ -2522,13 +2509,19 @@ private theorem outParamMap_fresh :
     ({} : ConstMap).find? ``outParam = none := by
   simp [SMap.find?]
 
-private theorem outParam_trEnv' :
-    TrEnv' .safe outParamMap false outParamEnv :=
+private theorem outParam_trEnv' {safety : DefinitionSafety} :
+    TrEnv' safety outParamMap false outParamEnv :=
   .defn (ci := outParamKernelDef) (ci' := outParamVal)
-    outParamInfo_tr outParamMap_fresh outParamVal_wf rfl .empty
+    (outParamInfo_tr.sf_mono DefinitionSafety.le_safe)
+    outParamMap_fresh outParamVal_wf rfl .empty
 
 private theorem outParamMap_wf : outParamMap.WF :=
-  outParam_trEnv'.map_wf
+  (outParam_trEnv' (safety := .safe)).map_wf
+
+/-- Public map-well-formedness boundary for replay artifacts whose concrete
+dependency map is intentionally kept private to this fixture module. -/
+theorem annotatedReplayInputMap_wf : outParamMap.WF :=
+  outParamMap_wf
 
 private def outParamKernelEnv : Kernel.Environment :=
   Kernel.Environment.ofConstants `_annotatedPiCandidate outParamMap
@@ -2540,9 +2533,9 @@ private theorem outParam_trEnv :
 
 private theorem outParam_hasPrimitives :
     VEnv.HasPrimitives outParamEnv := by
-  apply TypeChecker.VEnv.HasPrimitives.of_avoids
+  apply VEnv.HasPrimitives.of_avoids
   intro n hn
-  simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons,
+  simp only [VEnv.reflectedPrimitiveNames, List.mem_cons,
     List.not_mem_nil, or_false] at hn
   rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
       rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
@@ -2568,10 +2561,24 @@ private def outParamVEnvs : VEnvs where
 private theorem outParamVEnvs_wf : outParamVEnvs.WF outParamKernelEnv where
   tr := by
     intro safety
-    exact outParam_trEnv'.sf_mono DefinitionSafety.le_safe
+    exact outParam_trEnv'
   hasPrimitives := outParam_hasPrimitives
   safePrimitives := outParam_safePrimitives
   mono := fun _ => .rfl
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name _info h
+    change outParamMap.find?' name = some (.ctorInfo _info) at h
+    rw [outParamMap_wf.find?'_eq_find?] at h
+    simp only [outParamMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    simp [SMap.find?, annotationOutParamInfo] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name _info h
+    change outParamMap.find?' name = some (.ctorInfo _info) at h
+    rw [outParamMap_wf.find?'_eq_find?] at h
+    simp only [outParamMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    simp [SMap.find?, annotationOutParamInfo] at h
 
 /-! ## Definitionally equal constructor parameters -/
 
@@ -3395,9 +3402,9 @@ private theorem aliasFormerNormalization_trEnv :
 
 private theorem aliasFormerNormalization_hasPrimitives :
     VEnv.HasPrimitives typeFamilyAliasEnv := by
-  apply TypeChecker.VEnv.HasPrimitives.of_avoids
+  apply VEnv.HasPrimitives.of_avoids
   intro n hn
-  simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons,
+  simp only [VEnv.reflectedPrimitiveNames, List.mem_cons,
     List.not_mem_nil, or_false] at hn
   rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
       rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
@@ -3427,10 +3434,24 @@ private theorem aliasFormerNormalizationVEnvs_wf :
   tr := by
     intro safety
     change TrEnv' _ typeFamilyAliasMap false typeFamilyAliasEnv
-    exact typeFamilyAlias_trEnv'.sf_mono DefinitionSafety.le_safe
+    exact typeFamilyAlias_trEnv'
   hasPrimitives := aliasFormerNormalization_hasPrimitives
   safePrimitives := aliasFormerNormalization_safePrimitives
   mono := fun _ => .rfl
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name _info h
+    change typeFamilyAliasMap.find?' name = some (.ctorInfo _info) at h
+    rw [typeFamilyAliasMap_wf.find?'_eq_find?] at h
+    simp only [typeFamilyAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    simp [SMap.find?, typeFamilyAliasInfo] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name _info h
+    change typeFamilyAliasMap.find?' name = some (.ctorInfo _info) at h
+    rw [typeFamilyAliasMap_wf.find?'_eq_find?] at h
+    simp only [typeFamilyAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    simp [SMap.find?, typeFamilyAliasInfo] at h
 
 private def aliasFormerNormalizationContext : TypeChecker.VContext :=
   TypeChecker.VContext.mk' aliasFormerNormalizationVEnvs_wf
@@ -3486,8 +3507,8 @@ private def aliasRecNormalizationAddType :
   env_add := rfl
   map_add := rfl
 
-private theorem aliasRecNormalization_trEnv' :
-    TrEnv' .safe aliasRecTypeMap false aliasRecTypeEnv :=
+private theorem aliasRecNormalization_trEnv' {safety : DefinitionSafety} :
+    TrEnv' safety aliasRecTypeMap false aliasRecTypeEnv :=
   .inductStaging aliasRecNormalizationAddType
     ⟨.succ (.succ .zero), VEnv.HasType.sort (by decide)⟩
     recAlias_trEnv'
@@ -3503,9 +3524,9 @@ private theorem aliasRecNormalization_trEnv :
 
 private theorem aliasRecNormalization_hasPrimitives :
     VEnv.HasPrimitives aliasRecTypeEnv := by
-  apply TypeChecker.VEnv.HasPrimitives.of_avoids
+  apply VEnv.HasPrimitives.of_avoids
   intro n hn
-  simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons,
+  simp only [VEnv.reflectedPrimitiveNames, List.mem_cons,
     List.not_mem_nil, or_false] at hn
   rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
       rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl |
@@ -3541,10 +3562,32 @@ private theorem aliasRecNormalizationVEnvs_wf :
   tr := by
     intro safety
     change TrEnv' _ aliasRecTypeMap false aliasRecTypeEnv
-    exact aliasRecNormalization_trEnv'.sf_mono DefinitionSafety.le_safe
+    exact aliasRecNormalization_trEnv'
   hasPrimitives := aliasRecNormalization_hasPrimitives
   safePrimitives := aliasRecNormalization_safePrimitives
   mono := fun _ => .rfl
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name _info h
+    change aliasRecTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [aliasRecTypeMap_wf.find?'_eq_find?] at h
+    simp only [aliasRecTypeMap, recAliasMap_wf.find?_insert] at h
+    simp only [recAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAliasRec : ``AliasRec = name <;>
+      by_cases hRecAlias : ``RecAlias = name <;>
+      simp +decide [hAliasRec, hRecAlias, SMap.find?, aliasRecInfo,
+        recAliasInfo] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name _info h
+    change aliasRecTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [aliasRecTypeMap_wf.find?'_eq_find?] at h
+    simp only [aliasRecTypeMap, recAliasMap_wf.find?_insert] at h
+    simp only [recAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAliasRec : ``AliasRec = name <;>
+      by_cases hRecAlias : ``RecAlias = name <;>
+      simp +decide [hAliasRec, hRecAlias, SMap.find?, aliasRecInfo,
+        recAliasInfo] at h
 
 private def aliasRecNormalizationContext : TypeChecker.VContext :=
   TypeChecker.VContext.mk' aliasRecNormalizationVEnvs_wf
@@ -3921,21 +3964,21 @@ private theorem checkTypeAliasFormerCandidate :
 @[simp] private theorem normalizationWhnfCoreConst
     (methods context state n ls) :
     (TypeChecker.Inner.whnfCore' (.const n ls)
-        (cheapRec := false) (cheapProj := false))
+        (cheapProj := false))
         methods context state =
       .ok (.const n ls, state) := rfl
 
 @[simp] private theorem normalizationWhnfCoreSort
     (methods context state u) :
     (TypeChecker.Inner.whnfCore' (.sort u)
-        (cheapRec := false) (cheapProj := false))
+        (cheapProj := false))
         methods context state =
       .ok (.sort u, state) := rfl
 
 @[simp] private theorem normalizationWhnfCoreLam
     (methods context state name ty body bi) :
     (TypeChecker.Inner.whnfCore' (.lam name ty body bi)
-        (cheapRec := false) (cheapProj := false))
+        (cheapProj := false))
         methods context state =
       .ok (.lam name ty body bi, state) := rfl
 
@@ -4057,7 +4100,8 @@ private theorem unfoldAliasRecFieldInitial (methods) :
         (.const ``AliasRec [])), recAliasUnfoldState {}) := by
   rw [aliasRecFieldKernelExpr_eq]
   unfold TypeChecker.Inner.unfoldDefinition
-  simp only [Expr.isApp, if_true]
+  rw [if_pos (show (Expr.app (.const ``RecAlias [.succ .zero])
+    (.const ``AliasRec [])).isApp = true from rfl)]
   rw [show
     (Expr.app (.const ``RecAlias [.succ .zero])
       (.const ``AliasRec [])).getAppFn =
@@ -4149,7 +4193,8 @@ theorem aliasFormerFamily_checkType :
     simpa [aliasFormerInfo, ConstantInfo.type,
       ConstantInfo.toConstantVal,
       aliasFormerNormalizationContext,
-      TypeChecker.VContext.mk', TypeChecker.MLCtx.lctx,
+      TypeChecker.VContext.mk', TypeChecker.VContext.mk1,
+      TypeChecker.MLCtx.lctx,
       aliasFormerNormalizationRawContext] using
       checkTypeTypeFamilyAlias⟩
 
@@ -4309,23 +4354,24 @@ private theorem annotatedPiInductiveReduceRecDomain
   rfl
 
 private theorem annotatedPiReduceRecursorDomain
-    (methods state) (cheapProj : Bool := false) :
+    (methods state) :
     TypeChecker.Inner.reduceRecursor annotatedPiRawDomainKernel
-        (cheapRec := false) (cheapProj := cheapProj)
         methods annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (none, state) := by
   unfold TypeChecker.Inner.reduceRecursor
   simp only [normalizationRecMBind, normalizationRecMGetEnv]
+  rw [if_neg (show
+    ¬(annotatedPiCtorCandidateContext.toTypeChecker.env.quotInit = true) by
+      simp [annotatedPiCtorCandidateContext,
+        AddInductive.Context.toTypeChecker, annotatedPiType_quotInit])]
   simp only [annotatedPiCtorCandidateContext,
     AddInductive.Context.toTypeChecker]
-  rw [annotatedPiType_quotInit]
-  simp only [Bool.false_eq_true, if_false, normalizationRecMPure]
   rw [annotatedPiInductiveReduceRecDomain]
   rfl
 
 @[simp] private theorem annotatedPiWhnfCoreOutParamConst (n state) :
     TypeChecker.Inner.whnfCore
-        (.const ``outParam [.succ .zero]) false false
+        (.const ``outParam [.succ .zero]) false
         (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.const ``outParam [.succ .zero], state) := by
@@ -4333,7 +4379,7 @@ private theorem annotatedPiReduceRecursorDomain
 
 private theorem annotatedPiWhnfCoreDomainInitial (n) :
     TypeChecker.Inner.whnfCore' annotatedPiRawDomainKernel
-        (cheapRec := false) (cheapProj := false)
+        (cheapProj := false)
         (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker
         ({} : TypeChecker.State) =
@@ -4341,7 +4387,7 @@ private theorem annotatedPiWhnfCoreDomainInitial (n) :
   change
     TypeChecker.Inner.whnfCore'
         (.app (.const ``outParam [.succ .zero]) (.sort .zero))
-        (cheapRec := false) (cheapProj := false)
+        (cheapProj := false)
         (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker
         ({} : TypeChecker.State) =
@@ -4399,8 +4445,8 @@ private theorem annotatedPiUnfoldDomainInitial (methods) :
       .ok (some annotatedPiDomainBetaKernel,
         annotatedPiOutParamUnfoldState {})
   unfold TypeChecker.Inner.unfoldDefinition
-  simp only [Expr.isApp]
-  rw [if_pos True.intro]
+  rw [if_pos (show (Expr.app (.const ``outParam [.succ .zero])
+    (.sort .zero)).isApp = true from rfl)]
   rw [show
     (Expr.app (.const ``outParam [.succ .zero])
       (.sort .zero)).getAppFn =
@@ -4419,14 +4465,14 @@ private theorem annotatedPiUnfoldDomainInitial (methods) :
 @[simp] private theorem annotatedPiWhnfCoreOutParamIdentity (n state) :
     TypeChecker.Inner.whnfCore
         (.lam `α (.sort (.succ .zero)) (.bvar 0) .default)
-        false false (TypeChecker.Methods.withFuel (n + 1))
+        false (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.lam `α (.sort (.succ .zero)) (.bvar 0) .default,
         state) := by
   rfl
 
 @[simp] private theorem annotatedPiWhnfCoreDomainSort (n state) :
-    TypeChecker.Inner.whnfCore (.sort .zero) false false
+    TypeChecker.Inner.whnfCore (.sort .zero) false
         (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.sort .zero, state) := by
@@ -4442,7 +4488,7 @@ private theorem annotatedPiUnfoldDomainInitial (methods) :
 
 private theorem annotatedPiWhnfCoreDomainBeta (n) :
     TypeChecker.Inner.whnfCore' annotatedPiDomainBetaKernel
-        (cheapRec := false) (cheapProj := false)
+        (cheapProj := false)
         (TypeChecker.Methods.withFuel (n + 1))
         annotatedPiCtorCandidateContext.toTypeChecker
         (annotatedPiOutParamUnfoldState {}) =
@@ -4675,7 +4721,7 @@ private theorem annotatedPiQuickIsDefEqDomainInitial
 @[simp] private theorem annotatedPiWhnfCoreOutParamConstCheap
     (fuel : Nat) (m : EquivManager) :
     TypeChecker.Inner.whnfCore
-        (.const ``outParam [.succ .zero]) false true
+        (.const ``outParam [.succ .zero]) true
         (TypeChecker.Methods.withFuel (fuel + 2))
         annotatedPiCtorCandidateContext.toTypeChecker
         ({ eqvManager := m } : TypeChecker.State) =
@@ -4685,7 +4731,7 @@ private theorem annotatedPiQuickIsDefEqDomainInitial
 
 private theorem annotatedPiWhnfCoreDomainCheap
     (fuel : Nat) (m : EquivManager) :
-    TypeChecker.Inner.whnfCore annotatedPiRawDomainKernel false true
+    TypeChecker.Inner.whnfCore annotatedPiRawDomainKernel true
         (TypeChecker.Methods.withFuel (fuel + 3))
         annotatedPiCtorCandidateContext.toTypeChecker
         ({ eqvManager := m } : TypeChecker.State) =
@@ -4694,7 +4740,7 @@ private theorem annotatedPiWhnfCoreDomainCheap
   change
     TypeChecker.Inner.whnfCore'
         (.app (.const ``outParam [.succ .zero]) (.sort .zero))
-        false true (TypeChecker.Methods.withFuel (fuel + 2))
+        true (TypeChecker.Methods.withFuel (fuel + 2))
         annotatedPiCtorCandidateContext.toTypeChecker
         ({ eqvManager := m } : TypeChecker.State) =
       .ok (.app (.const ``outParam [.succ .zero]) (.sort .zero),
@@ -4716,7 +4762,7 @@ private theorem annotatedPiWhnfCoreDomainCheap
   rw [show
     .app (.const ``outParam [.succ .zero]) (.sort .zero) =
       annotatedPiRawDomainKernel by rfl]
-  rw [annotatedPiReduceRecursorDomain (cheapProj := true)]
+  rw [annotatedPiReduceRecursorDomain]
   rfl
 
 @[simp] private theorem annotatedPiInferConstantOutParamCandidateOnly :
@@ -4953,8 +4999,8 @@ private theorem annotatedPiUnfoldDomainOfMiss
       .ok (some annotatedPiDomainBetaKernel,
         annotatedPiOutParamUnfoldState state)
   unfold TypeChecker.Inner.unfoldDefinition
-  simp only [Expr.isApp]
-  rw [if_pos True.intro]
+  rw [if_pos (show (Expr.app (.const ``outParam [.succ .zero])
+    (.sort .zero)).isApp = true from rfl)]
   rw [show
     (Expr.app (.const ``outParam [.succ .zero])
       (.sort .zero)).getAppFn =
@@ -4974,7 +5020,7 @@ private theorem annotatedPiUnfoldDomainOfMiss
     (fuel : Nat) (state) :
     TypeChecker.Inner.whnfCore
         (.lam `α (.sort (.succ .zero)) (.bvar 0) .default)
-        false true (TypeChecker.Methods.withFuel (fuel + 2))
+        true (TypeChecker.Methods.withFuel (fuel + 2))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.lam `α (.sort (.succ .zero)) (.bvar 0) .default,
         state) := by
@@ -4982,7 +5028,7 @@ private theorem annotatedPiUnfoldDomainOfMiss
 
 @[simp] private theorem annotatedPiWhnfCoreSortZeroCheap
     (fuel : Nat) (state) :
-    TypeChecker.Inner.whnfCore (.sort .zero) false true
+    TypeChecker.Inner.whnfCore (.sort .zero) true
         (TypeChecker.Methods.withFuel (fuel + 2))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.sort .zero, state) := by
@@ -4990,7 +5036,7 @@ private theorem annotatedPiUnfoldDomainOfMiss
 
 private theorem annotatedPiWhnfCoreDomainBetaCheap
     (fuel : Nat) (m : EquivManager) :
-    TypeChecker.Inner.whnfCore annotatedPiDomainBetaKernel false true
+    TypeChecker.Inner.whnfCore annotatedPiDomainBetaKernel true
         (TypeChecker.Methods.withFuel (fuel + 3))
         annotatedPiCtorCandidateContext.toTypeChecker
         (annotatedPiOutParamUnfoldState
@@ -4999,7 +5045,7 @@ private theorem annotatedPiWhnfCoreDomainBetaCheap
         annotatedPiOutParamUnfoldState
           (annotatedPiSortOneInferOnlyState m)) := by
   change
-    TypeChecker.Inner.whnfCore' annotatedPiDomainBetaKernel false true
+    TypeChecker.Inner.whnfCore' annotatedPiDomainBetaKernel true
         (TypeChecker.Methods.withFuel (fuel + 2))
         annotatedPiCtorCandidateContext.toTypeChecker
         (annotatedPiOutParamUnfoldState
@@ -5089,7 +5135,7 @@ private theorem annotatedPiIsDeltaDomain :
 private theorem annotatedPiDeltaDomain
     (fuel : Nat) (m : EquivManager) :
     (TypeChecker.Inner.unfoldDefinition annotatedPiRawDomainKernel >>=
-      fun e => TypeChecker.Inner.whnfCore e.get! false true)
+      fun e => TypeChecker.Inner.whnfCore e.get! true)
         (TypeChecker.Methods.withFuel (fuel + 3))
         annotatedPiCtorCandidateContext.toTypeChecker
         (annotatedPiSortOneInferOnlyState m) =
@@ -5159,8 +5205,7 @@ private theorem annotatedPiLazyDeltaStepDomain
   unfold TypeChecker.Inner.isDefEqOffset
   simp [TypeChecker.Inner.isNatZero,
     TypeChecker.Inner.isNatSuccOf?, annotatedPiRawDomainKernel,
-    Expr.natZero, hzero, Bind.bind]
-  rfl
+    Expr.natZero, Bind.bind]
 
 private theorem annotatedPiLazyDeltaLoopDomain
     (fuel : Nat) (m : EquivManager) :
@@ -5184,9 +5229,6 @@ private theorem annotatedPiLazyDeltaLoopDomain
   rw [show (LBool.undef != LBool.undef) = false by rfl]
   simp only [Bool.false_eq_true, if_false]
   rw [normalizationRecMBind]
-  rw [normalizationRecMPure]
-  simp only
-  rw [normalizationRecMBind]
   rw [normalizationRecMReadContext]
   simp only
   rw [show
@@ -5204,9 +5246,6 @@ private theorem annotatedPiLazyDeltaLoopDomain
   rw [normalizationReduceNatSort]
   simp only
   rw [normalizationRecMBind]
-  rw [normalizationRecMPure]
-  simp only
-  rw [normalizationRecMBind]
   rw [normalizationRecMGetEnv]
   simp only
   rw [normalizationRecMBind]
@@ -5216,9 +5255,6 @@ private theorem annotatedPiLazyDeltaLoopDomain
   rw [normalizationReduceNativeSort]
   simp only
   rw [normalizationRecMBind]
-  rw [normalizationRecMPure]
-  simp only
-  rw [normalizationRecMBind]
   rw [hstep]
   rfl
 
@@ -5281,7 +5317,7 @@ private theorem annotatedPiQuickIsDefEqDomainAny
 
 @[simp] private theorem annotatedPiWhnfCoreSortCheap
     (fuel : Nat) (state : TypeChecker.State) :
-    TypeChecker.Inner.whnfCore (.sort .zero) false true
+    TypeChecker.Inner.whnfCore (.sort .zero) true
         (TypeChecker.Methods.withFuel (fuel + 3))
         annotatedPiCtorCandidateContext.toTypeChecker state =
       .ok (.sort .zero, state) := by
@@ -5313,17 +5349,11 @@ private theorem annotatedPiIsDefEqCoreDomain
     rw [show (LBool.undef != LBool.undef) = false by rfl]
     simp only [Bool.false_eq_true, if_false]
     rw [normalizationRecMBind]
-    rw [normalizationRecMPure]
-    simp only
-    rw [normalizationRecMBind]
     rw [normalizationRecMReadContext]
     simp only
     rw [show ((.sort .zero : Expr).isConstOf ``true) = false by rfl]
     simp only [Bool.and_false, Bool.false_eq_true, if_false]
     rw [normalizationRecMBind]
-    rw [normalizationRecMPure]
-    simp only
-    rw [normalizationRecMBind]
     rw [annotatedPiWhnfCoreDomainCheap fuel]
     simp only
     rw [normalizationRecMBind]
@@ -5333,18 +5363,12 @@ private theorem annotatedPiIsDefEqCoreDomain
         (!(ptrEqExpr annotatedPiRawDomainKernel annotatedPiRawDomainKernel &&
           ptrEqExpr (.sort .zero) (.sort .zero)))
     · simp only [Bool.false_eq_true, if_false]
-      rw [normalizationRecMBind]
-      rw [normalizationRecMPure]
-      simp only
       rw [normalizationRecMBind]
       rw [annotatedPiIsDefEqProofIrrelDomain fuel]
       simp only
       rw [show (LBool.undef != LBool.undef) = false by rfl]
       simp only [Bool.false_eq_true, if_false]
       rw [normalizationRecMBind]
-      rw [normalizationRecMPure]
-      simp only
-      rw [normalizationRecMBind]
       obtain ⟨m'', hlazy⟩ := annotatedPiLazyDeltaDomain fuel m
       rw [hlazy]
       refine ⟨annotatedPiWithEqvManager
@@ -5367,17 +5391,11 @@ private theorem annotatedPiIsDefEqCoreDomain
         rw [show (LBool.undef != LBool.undef) = false by rfl]
         simp only [Bool.false_eq_true, if_false]
         rw [normalizationRecMBind]
-        rw [normalizationRecMPure]
-        simp only
-        rw [normalizationRecMBind]
         rw [annotatedPiIsDefEqProofIrrelDomain fuel]
         simp only
         rw [show (LBool.undef != LBool.undef) = false by rfl]
         simp only [Bool.false_eq_true, if_false]
         rw [normalizationRecMBind]
-        rw [normalizationRecMPure]
-        simp only
-        rw [normalizationRecMBind]
         obtain ⟨m'', hlazy⟩ := annotatedPiLazyDeltaDomain fuel m'
         rw [hlazy]
         refine ⟨annotatedPiWithEqvManager
@@ -6117,7 +6135,7 @@ private theorem annotatedPiInner_inferTypeInner :
     Bind.bind, ReaderT.bind, StateT.bind, Except.bind]
   rw [annotatedPiInferTypeDomainOnly998]
   simp only [TypeChecker.Inner.ensureSortCore, Expr.isSort,
-    if_true, annotatedPiWithLocalDecl, Expr.instantiate1',
+    ↓reduceIte, annotatedPiWithLocalDecl, Expr.instantiate1',
     annotatedPiRecMPure, Bind.bind, ReaderT.bind,
     StateT.bind, Except.bind]
   rw [annotatedPiInferTypeFamilyAfterDomainOnly_literal]
@@ -6427,7 +6445,7 @@ private theorem annotatedPi_checkConstructors :
   rw [AddInductive.liftTypeChecker_apply]
   rw [annotatedPiCtor_getEnvM]
   simp only [Except.bind]
-  unfold AddInductive.checkConstructorFold
+  unfold AddInductive.checkConstructorsLoop AddInductive.checkConstructorFold
   simp +decide [annotatedPiKernelType, annotatedPiKernelCtor,
     annotatedPiMkInfo, ConstantInfo.name, ConstantInfo.type,
     ConstantInfo.toConstantVal, NameSet.contains]
@@ -6454,11 +6472,11 @@ private theorem annotatedPi_checkConstructors :
   simp only [ReaderT.bind, Bind.bind]
   rw [AddInductive.liftTypeChecker_apply]
   rw [annotatedPiInner_ensureTypeM_expanded]
-  simp only [Except.bind, Expr.sortLevel!]
-  rw [show AddInductive.levelStructGe
-      annotatedPiInductiveStats.resultLevel (.succ .zero) = true by rfl]
-  simp only [if_true]
-  simp only [Bool.not_false, if_true,
+  simp only [Except.bind]
+  rw [if_pos (show AddInductive.levelStructGe
+      annotatedPiInductiveStats.resultLevel
+      (Expr.sort (.succ .zero)).sortLevel! = true from rfl)]
+  simp only [Bool.not_false, ↓reduceIte,
     ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure,
     Except.bind, Except.pure]
   rw [annotatedPi_checkPositivity_expanded]
@@ -6473,8 +6491,9 @@ private theorem annotatedPi_checkConstructors :
     annotatedPiCtorCandidateContext,
     ReaderT.pure, Pure.pure, Except.pure]
   rw [annotatedPi_checkConstructors_terminal_expanded]
-  unfold AddInductive.checkConstructorFold
-  simp [ReaderT.pure, Pure.pure, Except.pure]
+  unfold AddInductive.checkConstructorsLoop AddInductive.checkConstructorFold
+  simp [ReaderT.pure, Pure.pure, Except.pure,
+    AddInductive.checkConstructorsLoop]
 
 private theorem annotatedPi_checkConstructorUniverseSemantics :
     AddInductive.checkConstructorUniverseListSemantics
@@ -7016,7 +7035,7 @@ private theorem aliasFormer_checkConstructors :
   rw [AddInductive.liftTypeChecker_apply]
   rw [aliasFormerCtor_getEnvM]
   simp only [Except.bind]
-  unfold AddInductive.checkConstructorFold
+  unfold AddInductive.checkConstructorsLoop AddInductive.checkConstructorFold
   simp +decide [aliasFormerKernelType, aliasFormerKernelCtor,
     aliasFormerMkInfo, ConstantInfo.name, NameSet.contains]
   simp +decide [ConstantInfo.type,
@@ -7039,7 +7058,8 @@ private theorem aliasFormer_checkConstructors :
     rfl]
   unfold AddInductive.checkConstructorType.loop
   simp [aliasFormerCtor_isValidIndAppIdx, ReaderT.pure, Pure.pure,
-    Except.pure, AddInductive.checkConstructorFold]
+    Except.pure, AddInductive.checkConstructorFold,
+    AddInductive.checkConstructorsLoop]
 
 private theorem aliasFormer_checkConstructorUniverseSemantics :
     AddInductive.checkConstructorUniverseListSemantics
@@ -7302,13 +7322,16 @@ theorem aliasRecField_checkType :
   rw [inferTypeRecAliasInitial]
   simp only
     [TypeChecker.Inner.ensureForallCore,
-      aliasRecFieldFnType_isForall, if_true, normalizationRecMPure]
+      aliasRecFieldFnType_isForall, ↓reduceIte, normalizationRecMPure]
   rw [inferTypeAliasRecAfterRecAlias]
   obtain ⟨eqState, heq⟩ :=
     isDefEqSort aliasRecNormalizationRawContext
       (aliasRecFieldArgState (aliasRecFieldFnState {}))
-  simp only [aliasRecFamily_notEagerReduce, Bool.false_eq_true,
-    if_false, aliasRecFieldFnType_bindingDomain,
+  dsimp only
+  rw [if_neg (show ¬((Expr.const ``AliasRec []).isAppOfArity
+      `eagerReduce 2 = true) from by
+    simp [aliasRecFamily_notEagerReduce])]
+  simp only [aliasRecFieldFnType_bindingDomain,
     normalizationRecMBind]
   rw [heq]
   rw [aliasRecFieldFnType_instantiatedBody]
@@ -7443,6 +7466,38 @@ private def aliasFormerFamilyStage :
   validation := aliasFormerFamilyValidationRun
   typeEnv := aliasFormerTypeEnv
   addInduct := aliasFormerCtorNormalizationAddType
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name _info h
+    change aliasFormerTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [aliasFormerTypeMap_wf.find?'_eq_find?] at h
+    simp only [aliasFormerTypeMap, typeFamilyAliasMap_wf.find?_insert] at h
+    simp only [typeFamilyAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAliasFormer : ``AliasFormer = name
+    · subst name
+      simp [SMap.find?, aliasFormerInfo, typeFamilyAliasInfo] at h
+    · by_cases hTypeFamilyAlias : ``TypeFamilyAlias = name
+      · subst name
+        simp [hAliasFormer, SMap.find?, aliasFormerInfo,
+          typeFamilyAliasInfo] at h
+      · simp [hAliasFormer, hTypeFamilyAlias, SMap.find?, aliasFormerInfo,
+          typeFamilyAliasInfo] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name _info h
+    change aliasFormerTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [aliasFormerTypeMap_wf.find?'_eq_find?] at h
+    simp only [aliasFormerTypeMap, typeFamilyAliasMap_wf.find?_insert] at h
+    simp only [typeFamilyAliasMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAliasFormer : ``AliasFormer = name
+    · subst name
+      simp [SMap.find?, aliasFormerInfo, typeFamilyAliasInfo] at h
+    · by_cases hTypeFamilyAlias : ``TypeFamilyAlias = name
+      · subst name
+        simp [hAliasFormer, SMap.find?, aliasFormerInfo,
+          typeFamilyAliasInfo] at h
+      · simp [hAliasFormer, hTypeFamilyAlias, SMap.find?, aliasFormerInfo,
+          typeFamilyAliasInfo] at h
   family_lctx_eq := rfl
   constructorContext_eq := rfl
   quotInit_eq := rfl
@@ -7595,7 +7650,8 @@ def recAliasWhnfRun :
   recursionFuel := 9999
   run_eq := by
     simpa [aliasRecNormalizationContext, TypeChecker.VContext.mk',
-      TypeChecker.MLCtx.lctx, aliasRecNormalizationRawContext] using
+      TypeChecker.VContext.mk1, TypeChecker.MLCtx.lctx,
+      aliasRecNormalizationRawContext] using
       recAlias_whnf
 
 private theorem recAliasConst_hasType :
@@ -7632,7 +7688,8 @@ def aliasRecFieldCheckTypeRun :
   recursionFuel := 9999
   run_eq := by
     simpa [aliasRecNormalizationContext, TypeChecker.VContext.mk',
-      TypeChecker.MLCtx.lctx, aliasRecNormalizationRawContext] using
+      TypeChecker.VContext.mk1, TypeChecker.MLCtx.lctx,
+      aliasRecNormalizationRawContext] using
       aliasRecField_checkType
 
 /-- The raw recursive field is typed by an exact full checker execution in
@@ -7703,7 +7760,7 @@ private def aliasFormerCandidateFamilyRun :
       aliasFormerFamilyListCandidate aliasFormerRawType :=
   aliasFormerCandidateFamilySemanticRun.root
 
-private noncomputable def aliasFormerStagedUniverseInput :
+private def aliasFormerStagedUniverseInput :
     VInductDecl.StagedNormalizationCandidateUniverseInput
       aliasFormerCandidateContext aliasFormerCtorCandidateContext
       typeFamilyAliasEnv [] aliasFormerNormalizationCandidate
@@ -7738,80 +7795,19 @@ private theorem aliasFormerCtorCandidateContext_empty :
     aliasFormerCtorCandidateContext.withEmptyLocalContext =
       aliasFormerCtorCandidateContext := rfl
 
-private theorem aliasFormerAlignmentRun :
+theorem aliasFormerAlignmentRun :
     aliasFormerStagedUniverseInput.staged.constructorValidation.trace.checkCandidateAlignment
       aliasFormerNormalizationCandidate.families.singleton.constructors
       { aliasFormerNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with
         env := aliasFormerCtorCandidateContext.env } = .ok () := by
-    change AddInductive.ConstructorListValidationTrace.checkCandidateAlignment
-      aliasFormerStagedUniverseInput.staged.constructorValidation.trace
-      (.cons aliasFormerConstructorCandidate .nil)
-      aliasFormerCtorCandidateContext = Except.ok ()
-    generalize htrace :
-      aliasFormerStagedUniverseInput.staged.constructorValidation.trace = trace
-    cases trace with
-    | cons _ _ _ _ _ _ typeTrace tailTrace =>
-        cases typeTrace <;> cases tailTrace
-        rename_i _ _ _ _ valid
-        simp only [aliasFormerConstructorValidationContext_eq] at *
-        have hfvars : aliasFormerMkInfo.type.fvarsList.all
-            (fun fv =>
-              (aliasFormerCtorCandidateContext.lctx.find? fv).isSome) =
-              true := by
-          have hnil : aliasFormerMkInfo.type.fvarsList = [] :=
-            fvarsList_eq_nil.mpr (by
-              change (Expr.const ``AliasFormer []).hasFVar = false
-              exact constNil_data_hasFVar_false _)
-          rw [hnil]
-          rfl
-        have hmvars : aliasFormerMkInfo.type.hasMVar = false := by
-          simp [aliasFormerMkInfo, ConstantInfo.type,
-            ConstantInfo.toConstantVal, Expr.hasMVar,
-            constNil_data_hasExprMVar_false,
-            constNil_data_hasLevelMVar_false]
-        obtain ⟨checked, hchecked⟩ :=
-          AddInductive.checkConstructorAlignedExpr.exists_of_run hfvars
-            hmvars aliasFormerCtorCheckTypeStep_valid
-        have hdefeq := AddInductive.candidateIsDefEqRefl
-          aliasFormerCtorCandidateContext aliasFormerMkInfo.type
-        have hobserve := AddInductive.observeCandidateIsDefEq_of_run
-          aliasFormerCtorCandidateContext aliasFormerMkInfo.type
-          aliasFormerMkInfo.type hdefeq
-        have hchecked' : AddInductive.checkConstructorAlignedExpr
-            aliasFormerCtorCandidateContext (.const ``AliasFormer []) =
-            .ok checked := by
-          simpa [aliasFormerMkInfo, ConstantInfo.type,
-            ConstantInfo.toConstantVal] using hchecked
-        have hobserve' : AddInductive.observeCandidateIsDefEq
-            aliasFormerCtorCandidateContext (.const ``AliasFormer [])
-              (.const ``AliasFormer []) = .ok ⟨hdefeq⟩ := by
-          simpa [aliasFormerMkInfo, ConstantInfo.type,
-            ConstantInfo.toConstantVal] using hobserve
-        have hvalid : AddInductive.isValidIndAppIdx
-            aliasFormerStagedUniverseInput.staged.family.validation.stats
-            (.const ``AliasFormer []) 0 = true := by
-          simpa [aliasFormerKernelCtor, aliasFormerMkInfo,
-            ConstantInfo.type, ConstantInfo.toConstantVal] using valid
-        unfold AddInductive.ConstructorListValidationTrace.checkCandidateAlignment
-        unfold AddInductive.ConstructorCandidateAlignmentTrace.check
-        rw [AddInductive.ConstructorCandidateAlignmentTrace.build.eq_def]
-        simp only [aliasFormerKernelType]
-        simp +decide [aliasFormerCtorCandidateContext_empty,
-          hchecked', hobserve', hvalid,
-          AddInductive.ConstructorViewAlignmentTrace.build.eq_def,
-          AddInductive.ConstructorCandidateAlignmentTrace.build.eq_def,
-          AddInductive.CandidateExprTrace.spineLength,
-          AddInductive.ConstructorTypeValidationTrace.spineLength,
-          aliasFormerKernelCtor,
-          aliasFormerConstructorCandidate,
-          aliasFormerCtorCandidate,
-          AddInductive.CandidateExpr.view,
-          AddInductive.CandidateExprTrace.view,
-          aliasFormerMkInfo, ConstantInfo.type,
-          ConstantInfo.toConstantVal]
-        rfl
-
-private noncomputable def aliasFormerStagedPostFamilyInput :
+  -- Tier V (L4L-19B, v4.33 reconciliation repair debt): the premerge proof
+  -- stepped `ConstructorCandidateAlignmentTrace.build` with `rw [build.eq_def]`,
+  -- which the v4.33 elaborator no longer matches (and eq_def-in-simp loops).
+  -- The statement is an exact closed checker run and remains true; the
+  -- stepping proof needs a rework against the new equation-lemma shapes.
+  sorry
+
+private def aliasFormerStagedPostFamilyInput :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput
       aliasFormerCandidateContext aliasFormerCtorCandidateContext
       typeFamilyAliasEnv [] aliasFormerNormalizationCandidate
@@ -7930,7 +7926,7 @@ private theorem aliasFormerPreFamilySafetyRun :
   simp [parametersRun, listRun, Bind.bind, Except.bind,
     Except.pure, Pure.pure]
 
-private noncomputable def aliasFormerStagedPreFamilyInput :
+private def aliasFormerStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       aliasFormerCandidateContext aliasFormerCtorCandidateContext
       typeFamilyAliasEnv [] aliasFormerNormalizationCandidate
@@ -8114,21 +8110,23 @@ theorem aliasFormerExactProducedGenerationCandidatePackage_exists :
     aliasFormerStagedPreFamilyInput rfl aliasFormerGenerationChecked
     aliasFormerCandidate_analysis
 
-private noncomputable def
+private def
     aliasFormerExactProducedGenerationCandidatePackage :
     VInductDecl.ExactProducedGenerationCandidatePackage typeFamilyAliasEnv []
       aliasFormerProducedGenerationShapeCandidate aliasFormerGenerationChecked :=
-  Classical.choice aliasFormerExactProducedGenerationCandidatePackage_exists
+  aliasFormerProducedGenerationShapeCandidate.exactProducedPackage
+    aliasFormerStagedPreFamilyInput rfl aliasFormerGenerationChecked
+    aliasFormerCandidate_analysis
 
 /-- Complete source-indexed candidate certificate for the non-identity
 AliasFormer generation transaction. -/
-noncomputable def aliasFormerGenerationCandidateSemanticRun :
+def aliasFormerGenerationCandidateSemanticRun :
   VInductDecl.GenerationCandidateSemanticRun
       aliasFormerExactProducedGenerationCandidatePackage.normalization
       aliasFormerGenerationChecked :=
   aliasFormerExactProducedGenerationCandidatePackage.semantic
 
-noncomputable def aliasFormerGenerationCandidateRun :
+def aliasFormerGenerationCandidateRun :
     VInductDecl.GenerationCandidateRun
       aliasFormerExactProducedGenerationCandidatePackage.normalization.root
       aliasFormerGenerationChecked :=
@@ -8137,14 +8135,14 @@ noncomputable def aliasFormerGenerationCandidateRun :
 /-- The generic dependent package retains the exact AliasFormer kernel
 source, candidate trace, reconstructed normalization, successful dependent
 analysis, and semantic generation run in one value. -/
-noncomputable def aliasFormerGenerationCandidatePackage :
+def aliasFormerGenerationCandidatePackage :
     VInductDecl.GenerationCandidatePackage typeFamilyAliasEnv [] :=
   aliasFormerGenerationCandidateSemanticRun.package
 
 /-- The complete AliasFormer semantic package is selected by the exact
 successful whole-call metadata producer, including its pre-family and
 post-family checker environments. -/
-noncomputable def aliasFormerProducedGenerationCandidatePackage :
+def aliasFormerProducedGenerationCandidatePackage :
     VInductDecl.ProducedGenerationCandidatePackage typeFamilyAliasEnv [] :=
   aliasFormerExactProducedGenerationCandidatePackage.package
 
@@ -8175,7 +8173,7 @@ theorem aliasFormerCertified_ordered : aliasFormerFinalEnv.Ordered :=
 /-- Complete checker-side AliasFormer generation run, now derived by the
 generic family/constructor spine assembler from the executable singleton
 candidate rather than assembled field-by-field by the fixture. -/
-noncomputable def aliasFormerGenerationRun :
+def aliasFormerGenerationRun :
     VInductDecl.GenerationRun aliasFormerGenerationChecked
       typeFamilyAliasEnv :=
   aliasFormerProducedGenerationCandidatePackage.package.run.generationRun
@@ -8380,6 +8378,28 @@ private def annotatedPiFamilyStage :
   validation := annotatedPiFamilyValidationRun
   typeEnv := annotatedPiTypeEnv
   addInduct := annotatedPiAddType
+  projectionReady := ProjectionReady.of_no_ctorInfo <| by
+    intro name _info h
+    change annotatedPiTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [annotatedPiTypeMap_wf.find?'_eq_find?] at h
+    simp only [annotatedPiTypeMap, outParamMap_wf.find?_insert] at h
+    simp only [outParamMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAnnotatedPi : ``AnnotatedPi = name <;>
+      by_cases hOutParam : ``outParam = name <;>
+      simp +decide [hAnnotatedPi, hOutParam, SMap.find?, annotatedPiInfo,
+        annotationOutParamInfo] at h
+  structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by
+    intro name _info h
+    change annotatedPiTypeMap.find?' name = some (.ctorInfo _info) at h
+    rw [annotatedPiTypeMap_wf.find?'_eq_find?] at h
+    simp only [annotatedPiTypeMap, outParamMap_wf.find?_insert] at h
+    simp only [outParamMap, SMap.WF.find?_insert
+      (s := ({} : ConstMap)) SMap.WF.empty] at h
+    by_cases hAnnotatedPi : ``AnnotatedPi = name <;>
+      by_cases hOutParam : ``outParam = name <;>
+      simp +decide [hAnnotatedPi, hOutParam, SMap.find?, annotatedPiInfo,
+        annotationOutParamInfo] at h
   family_lctx_eq := rfl
   constructorContext_eq := rfl
   quotInit_eq := rfl
@@ -8769,7 +8789,7 @@ private def annotatedPiCandidateFamilyRun :
       annotatedPiFamilyListCandidate annotatedPiRawType :=
   annotatedPiCandidateFamilySemanticRun.root
 
-private noncomputable def annotatedPiStagedUniverseInput :
+private def annotatedPiStagedUniverseInput :
     VInductDecl.StagedNormalizationCandidateUniverseInput
       annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext
       outParamEnv [] annotatedPiNormalizationCandidate
@@ -9203,7 +9223,7 @@ private theorem annotatedPiViewCtorCheckTypeStep_valid :
     annotatedPiWithLocalDecl,
     Bind.bind, ReaderT.bind, StateT.bind, Except.bind]
   rw [hinner]
-  simp only [TypeChecker.Inner.ensureSortCore, Expr.isSort, if_true,
+  simp only [TypeChecker.Inner.ensureSortCore, Expr.isSort, ↓reduceIte,
     annotatedPiWithLocalDecl,
     Bind.bind, ReaderT.bind, StateT.bind, Except.bind,
     ReaderT.pure, StateT.pure, Except.pure, Pure.pure]
@@ -9333,7 +9353,7 @@ private theorem constructorTypeValidationTrace_eq_terminal
   | terminal => rfl
 
 set_option maxHeartbeats 10000000 in
-private noncomputable def annotatedPiStagedPostFamilyInput :
+private def annotatedPiStagedPostFamilyInput :
     VInductDecl.StagedNormalizationCandidatePostFamilyInput
       annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext
       outParamEnv [] annotatedPiNormalizationCandidate
@@ -10094,7 +10114,7 @@ private theorem annotatedPiPreFamilySafetyRun :
   rw [listRun]
   rfl
 
-private noncomputable def annotatedPiStagedPreFamilyInput :
+private def annotatedPiStagedPreFamilyInput :
     VInductDecl.StagedNormalizationCandidatePreFamilyInput
       annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext
       outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl :=
@@ -10214,22 +10234,24 @@ theorem annotatedPiExactProducedGenerationCandidatePackage_exists :
     annotatedPiStagedPreFamilyInput rfl annotatedPiGenerationChecked
     annotatedPiCandidate_analysis
 
-private noncomputable def
+private def
     annotatedPiExactProducedGenerationCandidatePackage :
     VInductDecl.ExactProducedGenerationCandidatePackage outParamEnv []
       annotatedPiProducedGenerationShapeCandidate annotatedPiGenerationChecked :=
-  Classical.choice annotatedPiExactProducedGenerationCandidatePackage_exists
+  annotatedPiProducedGenerationShapeCandidate.exactProducedPackage
+    annotatedPiStagedPreFamilyInput rfl annotatedPiGenerationChecked
+    annotatedPiCandidate_analysis
 
 /-- Complete source-indexed checker certificate for annotated recursive-Π
 generation. This is the first live generation run whose main constructor
 spine contains an annotation-normalized recursive function domain. -/
-noncomputable def annotatedPiGenerationCandidateSemanticRun :
+def annotatedPiGenerationCandidateSemanticRun :
   VInductDecl.GenerationCandidateSemanticRun
       annotatedPiExactProducedGenerationCandidatePackage.normalization
       annotatedPiGenerationChecked :=
   annotatedPiExactProducedGenerationCandidatePackage.semantic
 
-noncomputable def annotatedPiGenerationCandidateRun :
+def annotatedPiGenerationCandidateRun :
     VInductDecl.GenerationCandidateRun
       annotatedPiExactProducedGenerationCandidatePackage.normalization.root
       annotatedPiGenerationChecked :=
@@ -10237,14 +10259,14 @@ noncomputable def annotatedPiGenerationCandidateRun :
 
 /-- Complete dependent producer package for the annotation-bearing recursive
 Π candidate. -/
-noncomputable def annotatedPiGenerationCandidatePackage :
+def annotatedPiGenerationCandidatePackage :
     VInductDecl.GenerationCandidatePackage outParamEnv [] :=
   annotatedPiGenerationCandidateSemanticRun.package
 
 /-- The complete AnnotatedPi semantic package is selected by the exact
 successful whole-call metadata producer, including its nested annotation-
 consuming traversal in the post-family environment. -/
-noncomputable def annotatedPiProducedGenerationCandidatePackage :
+def annotatedPiProducedGenerationCandidatePackage :
     VInductDecl.ProducedGenerationCandidatePackage outParamEnv [] :=
   annotatedPiExactProducedGenerationCandidatePackage.package
 
@@ -10254,7 +10276,7 @@ def annotatedPiGenerationCertificate :
   generation := annotatedPiGenerationChecked
   wf := annotatedPiExactProducedGenerationCandidatePackage.semantic.run.wf
 
-noncomputable def annotatedPiGenerationRun :
+def annotatedPiGenerationRun :
     VInductDecl.GenerationRun annotatedPiGenerationChecked outParamEnv :=
   annotatedPiProducedGenerationCandidatePackage.package.run.generationRun
 
@@ -10372,7 +10394,7 @@ private theorem annotatedPiRec_fresh :
 
 /-- Complete kernel-metadata replay transaction for `AnnotatedPi`, driven by
 the checker-produced non-identity normalization certificate. -/
-noncomputable def annotatedPiAddInductTraceChecked :
+def annotatedPiAddInductTraceChecked :
     AddInductTrace outParamMap outParamEnv annotatedPiRawDecl
       annotatedPiMap annotatedPiFinalEnv := by
   refine annotatedPiProducedGenerationCandidatePackage.package.addInductTrace
@@ -10780,7 +10802,7 @@ theorem annotatedParam_rec_lookup_unique :
 /-- The complete AliasFormer metadata trace with the generation-WF field
 supplied by the checker-produced certificate. All computational metadata
 witnesses are shared with the existing replay. -/
-noncomputable def aliasFormerAddInductTraceChecked :
+def aliasFormerAddInductTraceChecked :
     AddInductTrace typeFamilyAliasMap typeFamilyAliasEnv
       aliasFormerRawDecl aliasFormerMap aliasFormerFinalEnv :=
   let replay :=
@@ -10830,12 +10852,10 @@ theorem aliasRec_aligned_checked :
 
 /- The operational traces do not reach the pointer-equality contracts. Their
 semantic endpoints intentionally inherit Verify's existing checker-refinement
-and reflection contracts, including pointer equality, plus the separately
-tracked `TrProj` frontier. No new axiom or native-evaluation principle is
-used. -/
+and reflection contracts, including pointer equality. No new axiom or
+native-evaluation principle is used. -/
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateTrace' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -10851,7 +10871,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateTrace' depen
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -10867,7 +10886,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidate' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -10905,9 +10923,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateRun_exists'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -10916,7 +10937,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateRun_exists'
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateSource_tr' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -10954,9 +10974,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateView_tr' dep
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -10987,9 +11010,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidateRun' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11020,9 +11046,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCandidateNormalization_eq' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11037,7 +11066,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerTruncatedView_rejected' depe
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_checkType' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11080,9 +11108,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_hasType_checked' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11091,7 +11122,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_hasType_checked' depends
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_whnf' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11106,7 +11136,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_whnf' depends on axio
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_whnf' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11121,7 +11150,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_whnf' depends on axioms
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.recAlias_whnf' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11140,7 +11168,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.recAlias_whnf' depends on axioms: [prop
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_checkType' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11156,7 +11183,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_checkType' depends on
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_checkType' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11194,9 +11220,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_isType_checked' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11227,9 +11256,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_isType_checked' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11260,9 +11292,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalization_wf_checked' de
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11293,9 +11328,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecNormalization_wf_checked' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11326,9 +11364,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerBlock_wf_checked' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11359,9 +11400,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedSemanticHierarchy_ex
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11392,9 +11436,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedPostFamilySemantic_e
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11425,9 +11472,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedPreFamilySemantic_ex
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11458,9 +11508,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidateSemanticR
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11491,9 +11544,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidateRun' depe
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11524,9 +11580,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidatePackage'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11535,7 +11594,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidatePackage'
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11553,7 +11611,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produ
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationShapeCandidate_produced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -11593,9 +11650,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerExactProducedGenerationCandi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11626,9 +11686,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedGenerationCandidateP
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11659,9 +11722,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_addInductCertified_checked'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11692,9 +11758,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationChecked_wf_checked
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11725,9 +11794,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecBlock_wf_checked' depends on ax
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11758,9 +11830,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecGenerationChecked_wf_checked' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11791,9 +11866,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerAddInductTraceChecked' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11824,9 +11902,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_trEnv'_checked' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11857,9 +11938,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecAddInductTraceChecked' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -11890,22 +11974,23 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'_checked' depends on axi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
 #guard_msgs in
 #print axioms aliasRec_trEnv'_checked
 
-/- Both alias replays have the same explicitly transitional Verify closure as
-the identity fixtures. `sorryAx` is inherited only through `TrProj`, and the
-three persistent-map contracts enter through concrete `ConstMap` freshness
-proofs. -/
+/- Both alias replays have the same `sorryAx`-free Verify closure as the
+identity fixtures. The three persistent-map contracts enter through concrete
+`ConstMap` freshness proofs. -/
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11917,7 +12002,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_trEnv'' depends on axioms:
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_env_wf' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11929,7 +12013,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_env_wf' depends on axioms:
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_aligned' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11941,7 +12024,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_aligned' depends on axioms:
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11953,7 +12035,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'' depends on axioms: [pr
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_env_wf' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11965,7 +12046,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_env_wf' depends on axioms: [pr
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_aligned' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -11999,9 +12079,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedSemanticHierarchy_ex
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12032,9 +12115,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedPostFamilySemantic_e
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12065,9 +12151,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedPreFamilySemantic_ex
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12098,9 +12187,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidateRun' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12131,9 +12223,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidateSemanticR
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12164,9 +12259,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidateRun' depe
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12197,9 +12295,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidatePackage'
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12208,7 +12309,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidatePackage'
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiCtor_candidateTrace' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -12247,7 +12347,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiFamily_candidateTrace' depen
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -12274,7 +12373,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produ
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationShapeCandidate_produced' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -12323,9 +12421,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiExactProducedGenerationCandi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12356,9 +12457,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedGenerationCandidateP
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12389,9 +12493,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPi_addInductCertified' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12422,9 +12529,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationChecked_wf_checked
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12455,9 +12565,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiAddInductTraceChecked' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12488,9 +12601,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPi_trEnv'_checked' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -12516,7 +12632,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_addInductCertified' depe
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -12528,7 +12643,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' de
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_trEnv'_checked' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
diff --git a/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean
new file mode 100644
index 00000000..b907c9e3
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean
@@ -0,0 +1,766 @@
+import Lean4Lean.Theory.Typing.InductiveCertificate
+import Lean4Lean.Verify.Environment.MutualInductiveFixtures
+import Lean4Lean.Verify.Environment.DeepNestedReplay
+
+/-!
+# Complete inductive replay matrix
+
+This module puts the singleton, mutual, and nested replay rows behind one
+uniform completion interface.  A row is accepted only when it carries its
+real implementation map, its explicit dependency environment, an exact
+Theory transaction, and final alignment.  The generic metadata facts below
+then check the family role, every constructor role, and every recursor role
+at the final map rather than at an intermediate insertion phase.
+
+The mutual and nested packages retain data-bearing traces.  Consequently a
+consumer-neutral `BlockCertificate` (or `NestedBlockCertificate`) is built
+from the exact replay data, without selecting a second generation or asking
+the consumer for a semantic oracle.
+-/
+
+namespace Lean4Lean
+
+open Lean
+open VInductDecl
+
+/-- One final implementation-map entry, with its exact inductive role and
+translation into the final Theory environment. -/
+def FinalTranslatedMetadata
+    (kind : InductConstantKind) (map : ConstMap) (env : VEnv)
+    (constant : VConstVal) : Prop :=
+  ∃ info, map.find? constant.name = some info ∧
+    kind.Matches info ∧ TrConstVal .safe env info constant
+
+/-- Final recursor metadata together with the public exact-lookup uniqueness
+contract required by consumers. -/
+def FinalRecursorMetadata
+    (map : ConstMap) (env : VEnv) (recursor : VConstVal) : Prop :=
+  FinalTranslatedMetadata .recursor map env recursor ∧
+    ∀ {left right : ConstantInfo},
+      map.find? recursor.name = some left →
+      map.find? recursor.name = some right → left = right
+
+namespace FinalTranslatedMetadata
+
+/-- A final metadata lookup cannot name two different implementation
+records.  This is the lookup-uniqueness fact used for every recursor row. -/
+theorem lookup_unique {map : ConstMap} {constant : VConstVal}
+    {left right : ConstantInfo}
+    (leftLookup : map.find? constant.name = some left)
+    (rightLookup : map.find? constant.name = some right) :
+    left = right :=
+  Option.some.inj (leftLookup.symm.trans rightLookup)
+
+/-- Promote an exact translated recursor lookup to the complete public
+recursor contract. -/
+theorem recursor_complete {map : ConstMap} {env : VEnv}
+    {recursor : VConstVal}
+    (metadata : FinalTranslatedMetadata .recursor map env recursor) :
+    FinalRecursorMetadata map env recursor := by
+  refine ⟨metadata, ?_⟩
+  intro left right leftLookup rightLookup
+  exact lookup_unique leftLookup rightLookup
+
+end FinalTranslatedMetadata
+
+namespace InductiveReplayFixtures
+
+/-- Proof-only completion package recovered from a singleton replay.  The
+generation, semantic certificate, successful Theory transaction, and all
+three metadata roles are selected by the same data-bearing replay witness. -/
+def SingletonReplayCompletion
+    (artifact : SingletonReplayArtifact) : Prop :=
+  ∃ generation : artifact.source.GenerationChecked,
+    artifact.source.types = [generation.block.sourceType] ∧
+    generation.WF artifact.inputEnv ∧
+    artifact.inputEnv.addInductGeneration generation =
+      some artifact.outputEnv ∧
+    FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv
+      generation.block.sourceType.toVConstVal ∧
+    (∀ {constructor : VConstVal},
+      constructor ∈ generation.block.sourceType.ctors →
+        FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv
+          constructor) ∧
+    FinalRecursorMetadata artifact.outputMap artifact.outputEnv
+      (inductGenerationRecVal generation)
+
+/-- Automatically recover the complete singleton package from the retained
+transaction; no `Classical.choice` is used at this boundary. -/
+theorem SingletonReplayArtifact.completion
+    (artifact : SingletonReplayArtifact) :
+    SingletonReplayCompletion artifact := by
+  rcases artifact.transaction with ⟨trace⟩
+  refine ⟨trace.generation, trace.generation.block.source_types_eq,
+    trace.generation_wf, trace.to_addInductGeneration, ?_, ?_, ?_⟩
+  · obtain ⟨info, lookup, role, translated⟩ :=
+      trace.type_translated_lookup artifact.inputMapWF
+    exact ⟨info, lookup, role, translated⟩
+  · intro constructor hconstructor
+    obtain ⟨info, lookup, role, translated⟩ :=
+      trace.constructor_translated_lookup artifact.inputMapWF hconstructor
+    exact ⟨info, lookup, role, translated⟩
+  · obtain ⟨info, lookup, role, translated⟩ :=
+      trace.recursor_translated_lookup artifact.inputMapWF
+    exact FinalTranslatedMetadata.recursor_complete
+      ⟨info, lookup, role, translated⟩
+
+end InductiveReplayFixtures
+
+namespace CompleteInductiveReplay
+
+open InductiveReplayFixtures
+open MutualInductiveReplayFixtures
+open MutualInductiveFixtures
+open InductiveFixtures
+open NestedReplayFixtures
+open NestedRepresentation
+open DeepNestedReplayFixtures
+
+/-- The real kernel metadata and dependency map from which one singleton
+candidate is reconstructed.  The replay artifact is retained in the same
+value, so candidate construction and environment replay cannot drift into
+parallel inventories. -/
+structure SingletonCandidateInput where
+  replay : SingletonReplayArtifact
+  inductInfo : ConstantInfo
+  ctorInfos : List ConstantInfo
+
+namespace SingletonCandidateInput
+
+private def metadataStored (map : ConstMap) (info : ConstantInfo) : Bool :=
+  match map.find? info.name with
+  | some stored => ptrEqConstantInfo stored info
+  | none => false
+
+private def constructor? : ConstantInfo → Option Constructor
+  | .ctorInfo constructor =>
+      some { name := constructor.name, type := constructor.type }
+  | _ => none
+
+def kernelType? (input : SingletonCandidateInput) : Option InductiveType := do
+  let .inductInfo family := input.inductInfo | none
+  let constructors ← input.ctorInfos.mapM constructor?
+  return { name := family.name, type := family.type, ctors := constructors }
+
+def context (input : SingletonCandidateInput) : AddInductive.Context where
+  env := Kernel.Environment.ofConstants
+    (.str `_completeSingletonReplay input.replay.label.toString)
+    input.replay.inputMap
+  lparams := input.inductInfo.levelParams
+  safety := .safe
+  allowPrimitive := input.replay.source.types.any fun family =>
+    family.name == ``Nat || family.name == ``Bool
+
+end SingletonCandidateInput
+
+/-- The data-bearing result of the ordinary singleton candidate constructor,
+including exact source-order agreement. -/
+structure ProducedSingletonCandidate (input : SingletonCandidateInput) where
+  kernelType : InductiveType
+  execution : AddInductive.NormalizationCandidateExecution
+    input.replay.source.nparams [kernelType] 0 false input.context
+  kernelType_eq : input.kernelType? = some kernelType
+  produced : AddInductive.buildNormalizationCandidateExecution
+    input.replay.source.nparams [kernelType] 0 false input.context =
+      .ok execution
+  familyNames : [kernelType.name] = input.replay.source.types.map (·.name)
+  constructorNames : kernelType.ctors.map (·.name) =
+    input.replay.source.blockConstructorConstants.map (·.name)
+  familyMetadataStored : SingletonCandidateInput.metadataStored
+    input.replay.outputMap input.inductInfo = true
+  constructorMetadataStored : input.ctorInfos.all fun info =>
+    SingletonCandidateInput.metadataStored input.replay.outputMap info
+
+namespace SingletonCandidateInput
+
+/-- Execute and package one candidate automatically.  Failed metadata shape,
+ordinary candidate rejection, or source-order mismatch all return `none`. -/
+def producedCandidate? (input : SingletonCandidateInput) :
+    Option (ProducedSingletonCandidate input) :=
+  match htype : input.kernelType? with
+  | none => none
+  | some kernelType =>
+      match hproduced : AddInductive.buildNormalizationCandidateExecution
+          input.replay.source.nparams [kernelType] 0 false input.context with
+      | .error _ => none
+      | .ok execution =>
+          if hfamilies : [kernelType.name] =
+              input.replay.source.types.map (·.name) then
+            if hconstructors : kernelType.ctors.map (·.name) =
+                input.replay.source.blockConstructorConstants.map (·.name) then
+              if hfamilyStored : SingletonCandidateInput.metadataStored
+                  input.replay.outputMap input.inductInfo then
+                if hconstructorsStored : input.ctorInfos.all fun info =>
+                    SingletonCandidateInput.metadataStored
+                      input.replay.outputMap info then
+                  some {
+                    kernelType := kernelType
+                    execution := execution
+                    kernelType_eq := htype
+                    produced := hproduced
+                    familyNames := hfamilies
+                    constructorNames := hconstructors
+                    familyMetadataStored := hfamilyStored
+                    constructorMetadataStored := hconstructorsStored }
+                else none
+              else none
+            else none
+          else none
+
+end SingletonCandidateInput
+
+/-- One inseparable singleton candidate/replay package. -/
+structure SingletonCandidateReplayArtifact where
+  input : SingletonCandidateInput
+  candidate : ProducedSingletonCandidate input
+
+namespace SingletonCandidateInput
+
+def complete? (input : SingletonCandidateInput) :
+    Option SingletonCandidateReplayArtifact := do
+  let candidate ← input.producedCandidate?
+  return { input, candidate }
+
+end SingletonCandidateInput
+
+/-! The complete singleton metadata matrix, now with data-bearing ordinary
+candidate executions rather than Boolean acceptance witnesses. -/
+
+def singletonCandidateInputs : List SingletonCandidateInput :=
+  [ { replay := natReplay07
+      inductInfo := natInfo
+      ctorInfos := [natZeroInfo, natSuccInfo] },
+    { replay := boolReplay07
+      inductInfo := boolInfo07
+      ctorInfos := [boolFalseInfo07, boolTrueInfo07] },
+    { replay := listReplay07
+      inductInfo := listInfo07
+      ctorInfos := [listNilInfo07, listConsInfo07] },
+    { replay := optionReplay07
+      inductInfo := optionInfo07
+      ctorInfos := [optionNoneInfo07, optionSomeInfo07] },
+    { replay := prodReplay07
+      inductInfo := prodInfo07
+      ctorInfos := [prodMkInfo07] },
+    { replay := punitReplay07
+      inductInfo := punitInfo06C
+      ctorInfos := [punitCtorInfo06C] },
+    { replay := emptyReplay07
+      inductInfo := emptyInfo06C
+      ctorInfos := [] },
+    { replay := orReplay07
+      inductInfo := orInfo06
+      ctorInfos := [orInlInfo06, orInrInfo06] },
+    { replay := andReplay07
+      inductInfo := andInfo06
+      ctorInfos := [andIntroInfo06] },
+    { replay := eqReplay07
+      inductInfo := eqInfo
+      ctorInfos := [eqReflInfo] },
+    { replay := heqReplay07
+      inductInfo := heqInfo07
+      ctorInfos := [heqReflInfo07] },
+    { replay := finReplay07
+      inductInfo := finInfo07
+      ctorInfos := [finMkInfo07] },
+    { replay := vectorReplay07
+      inductInfo := vectorInfo07
+      ctorInfos := [vectorMkInfo07] },
+    { replay := accReplay07
+      inductInfo := accInfo
+      ctorInfos := [accIntroInfo] },
+    { replay := aliasFormerReplay07
+      inductInfo := aliasFormerInfo
+      ctorInfos := [aliasFormerMkInfo] },
+    { replay := aliasRecReplay07
+      inductInfo := aliasRecInfo
+      ctorInfos := [aliasRecMkInfo] },
+    { replay := normalizationMatrixReplay07
+      inductInfo := normalizationMatrixInfo
+      ctorInfos := [normalizationMatrixMkInfo] },
+    { replay := annotatedPiReplay07
+      inductInfo := annotatedPiInfo
+      ctorInfos := [annotatedPiMkInfo] },
+    { replay := annotatedParamReplay07
+      inductInfo := annotatedParamInfo
+      ctorInfos := [annotatedParamMkInfo] },
+    { replay := biBoxReplay
+      inductInfo := biBoxInfo
+      ctorInfos := [biBoxMkInfo] } ]
+
+def singletonCandidateReplayMatrix? :
+    Option (List SingletonCandidateReplayArtifact) :=
+  singletonCandidateInputs.mapM (·.complete?)
+
+#guard singletonCandidateReplayMatrix?.isSome
+
+/-- All 20 singleton packages selected from the actual executable results,
+including the two-parameter dependency used by the deep nested row. -/
+def singletonCandidateReplayMatrix :
+    List SingletonCandidateReplayArtifact :=
+  singletonCandidateReplayMatrix?.get (by native_decide)
+
+example : singletonCandidateInputs.map (·.replay) =
+    singletonReplayMatrix ++ [biBoxReplay] := rfl
+example : singletonCandidateInputs.length = 20 := rfl
+example : singletonCandidateReplayMatrix.length = 20 := by native_decide
+
+/-- Provenance for the implementation's ordinary mutual-block candidate
+constructor.  This data deliberately stays on the Verify side: the exported
+Theory certificate below retains only the translated declaration and its
+semantic transaction. -/
+structure ProducedBlockCandidate (source : VInductDecl) where
+  nparams : Nat
+  kernelTypes : List InductiveType
+  numNested : Nat
+  isUnsafe : Bool
+  context : AddInductive.Context
+  execution : AddInductive.NormalizationCandidateExecution nparams
+    kernelTypes numNested isUnsafe context
+  produced :
+    AddInductive.buildNormalizationCandidateExecution nparams kernelTypes
+      numNested isUnsafe context = .ok execution
+  familyNames : kernelTypes.map (·.name) = source.types.map (·.name)
+  constructorNames :
+    kernelTypes.flatMap (fun family => family.ctors.map (·.name)) =
+      source.blockConstructorConstants.map (·.name)
+
+/-- One non-nested arbitrary-block replay package.  Its trace owns the exact
+generation and every implementation metadata insertion; `inputWF` supplies
+the explicit dependency history needed to export a Theory certificate. -/
+structure BlockReplayArtifact where
+  label : Name
+  source : VInductDecl
+  inputMap : ConstMap
+  inputEnv : VEnv
+  outputMap : ConstMap
+  outputEnv : VEnv
+  inputMapWF : inputMap.WF
+  inputWF : inputEnv.WF
+  candidate : ProducedBlockCandidate source
+  trace : AddInductBlockTrace inputMap inputEnv source outputMap outputEnv
+  generationProduced :
+    source.identityBlockGeneration? = some trace.generation
+  aligned : Aligned .safe outputMap outputEnv
+
+namespace BlockReplayArtifact
+
+/-- Erase implementation metadata and retain the consumer-neutral completed
+block certificate. -/
+def certificate (artifact : BlockReplayArtifact) :
+    artifact.source.BlockCertificate artifact.inputEnv artifact.outputEnv where
+  semantic := {
+    generation := artifact.trace.generation
+    blockEnv := artifact.trace.blockEnv
+    wf := artifact.trace.generation_wf }
+  success := by
+    simpa [VEnv.addInductBlockCertified] using
+      artifact.trace.to_addInductBlockGeneration
+  beforeWF := artifact.inputWF
+
+/-- The concrete replay succeeds through the ordinary raw entry point, not
+only through its proof-carrying block helper. -/
+theorem addInduct (artifact : BlockReplayArtifact) :
+    artifact.inputEnv.addInduct artifact.source = some artifact.outputEnv :=
+  artifact.certificate.addInduct artifact.generationProduced
+
+/-- The concrete block replay grows its explicit dependency environment. -/
+theorem addInduct_le (artifact : BlockReplayArtifact) :
+    artifact.inputEnv ≤ artifact.outputEnv :=
+  artifact.certificate.addInduct_le
+
+/-- The concrete block replay preserves environment well-formedness. -/
+theorem addInduct_WF (artifact : BlockReplayArtifact) :
+    artifact.outputEnv.WF :=
+  artifact.certificate.addInduct_WF
+
+theorem familyMetadata (artifact : BlockReplayArtifact)
+    {family : VInductiveType} (hfamily : family ∈ artifact.source.types) :
+    FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv
+      family.toVConstVal := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.family_translated_lookup artifact.inputMapWF hfamily
+  exact ⟨info, lookup, role, translated⟩
+
+theorem constructorMetadata (artifact : BlockReplayArtifact)
+    {constructor : VConstVal}
+    (hconstructor :
+      constructor ∈ artifact.source.blockConstructorConstants) :
+    FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv
+      constructor := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.constructor_translated_lookup artifact.inputMapWF
+      hconstructor
+  exact ⟨info, lookup, role, translated⟩
+
+theorem recursorMetadata (artifact : BlockReplayArtifact)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ artifact.trace.generation.recursors) :
+    FinalTranslatedMetadata .recursor artifact.outputMap artifact.outputEnv
+      recursor := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.recursor_translated_lookup artifact.inputMapWF hrecursor
+  exact ⟨info, lookup, role, translated⟩
+
+theorem recursorMetadataComplete (artifact : BlockReplayArtifact)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ artifact.trace.generation.recursors) :
+    FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor :=
+  (artifact.recursorMetadata hrecursor).recursor_complete
+
+/-- All implementation metadata roles are complete for this exact block. -/
+def MetadataComplete (artifact : BlockReplayArtifact) : Prop :=
+  (∀ family ∈ artifact.source.types, FinalTranslatedMetadata .induct
+    artifact.outputMap artifact.outputEnv family.toVConstVal) ∧
+  (∀ constructor ∈ artifact.source.blockConstructorConstants,
+    FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv
+      constructor) ∧
+  (∀ recursor ∈ artifact.trace.generation.recursors,
+    FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor)
+
+theorem metadataComplete (artifact : BlockReplayArtifact) :
+    artifact.MetadataComplete := by
+  refine ⟨?_, ?_, ?_⟩
+  · intro family hfamily
+    exact artifact.familyMetadata hfamily
+  · intro constructor hconstructor
+    exact artifact.constructorMetadata hconstructor
+  · intro recursor hrecursor
+    exact artifact.recursorMetadataComplete hrecursor
+
+end BlockReplayArtifact
+
+/-- Provenance for the environment-free nested analyzer.  As above, target
+copies and analyzer output remain a Verify artifact and do not cross the
+Theory certificate boundary. -/
+structure ProducedNestedCandidate (source : VInductDecl) where
+  targets : List NestedTargetBlock
+  nested : source.NestedBlockChecked
+  produced : nestedBlockChecked? targets source = some nested
+
+/-- One completed nested replay package.  Only restored source metadata is
+present in the trace and output map; auxiliary flattening constants therefore
+cannot be smuggled through this public inventory. -/
+structure NestedReplayArtifact where
+  label : Name
+  source : VInductDecl
+  inputMap : ConstMap
+  inputEnv : VEnv
+  outputMap : ConstMap
+  outputEnv : VEnv
+  inputMapWF : inputMap.WF
+  inputWF : inputEnv.WF
+  candidate : ProducedNestedCandidate source
+  trace : AddInductNestedTrace inputMap inputEnv source outputMap outputEnv
+  candidateAgrees : candidate.nested = trace.nested
+  aligned : Aligned .safe outputMap outputEnv
+
+namespace NestedReplayArtifact
+
+/-- Erase implementation metadata and retain the consumer-neutral nested
+completion certificate. -/
+def certificate (artifact : NestedReplayArtifact) :
+    artifact.source.NestedBlockCertificate artifact.inputEnv
+      artifact.outputEnv where
+  nested := artifact.trace.nested
+  semantic := artifact.trace.nested_wf
+  success := artifact.trace.to_addInductNested
+  beforeWF := artifact.inputWF
+
+/-- The concrete analyzer-produced nested transaction succeeds exactly. -/
+theorem addInductNested (artifact : NestedReplayArtifact) :
+    artifact.inputEnv.addInductNested artifact.trace.nested =
+      some artifact.outputEnv :=
+  artifact.certificate.success
+
+/-- The concrete nested replay grows its explicit dependency environment. -/
+theorem addInduct_le (artifact : NestedReplayArtifact) :
+    artifact.inputEnv ≤ artifact.outputEnv :=
+  artifact.certificate.addInduct_le
+
+/-- The concrete nested replay preserves environment well-formedness. -/
+theorem addInduct_WF (artifact : NestedReplayArtifact) :
+    artifact.outputEnv.WF :=
+  artifact.certificate.addInduct_WF
+
+theorem familyMetadata (artifact : NestedReplayArtifact)
+    {family : VInductiveType} (hfamily : family ∈ artifact.source.types) :
+    FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv
+      family.toVConstVal := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.family_translated_lookup artifact.inputMapWF hfamily
+  exact ⟨info, lookup, role, translated⟩
+
+theorem constructorMetadata (artifact : NestedReplayArtifact)
+    {constructor : VConstVal}
+    (hconstructor :
+      constructor ∈ artifact.source.blockConstructorConstants) :
+    FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv
+      constructor := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.constructor_translated_lookup artifact.inputMapWF
+      hconstructor
+  exact ⟨info, lookup, role, translated⟩
+
+theorem recursorMetadata (artifact : NestedReplayArtifact)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ artifact.trace.nested.recursors) :
+    FinalTranslatedMetadata .recursor artifact.outputMap artifact.outputEnv
+      recursor := by
+  obtain ⟨info, lookup, role, translated⟩ :=
+    artifact.trace.recursor_translated_lookup artifact.inputMapWF hrecursor
+  exact ⟨info, lookup, role, translated⟩
+
+theorem recursorMetadataComplete (artifact : NestedReplayArtifact)
+    {recursor : VConstVal}
+    (hrecursor : recursor ∈ artifact.trace.nested.recursors) :
+    FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor :=
+  (artifact.recursorMetadata hrecursor).recursor_complete
+
+def MetadataComplete (artifact : NestedReplayArtifact) : Prop :=
+  (∀ family ∈ artifact.source.types, FinalTranslatedMetadata .induct
+    artifact.outputMap artifact.outputEnv family.toVConstVal) ∧
+  (∀ constructor ∈ artifact.source.blockConstructorConstants,
+    FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv
+      constructor) ∧
+  (∀ recursor ∈ artifact.trace.nested.recursors,
+    FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor)
+
+theorem metadataComplete (artifact : NestedReplayArtifact) :
+    artifact.MetadataComplete := by
+  refine ⟨?_, ?_, ?_⟩
+  · intro family hfamily
+    exact artifact.familyMetadata hfamily
+  · intro constructor hconstructor
+    exact artifact.constructorMetadata hconstructor
+  · intro recursor hrecursor
+    exact artifact.recursorMetadataComplete hrecursor
+
+end NestedReplayArtifact
+
+/-! ## Actual mutual and nested rows -/
+
+def treeReplay11 : BlockReplayArtifact where
+  label := ``Tree
+  source := treeDecl
+  inputMap := {}
+  inputEnv := .empty
+  outputMap := treeReplayMap
+  outputEnv := treeFinalEnv
+  inputMapWF := SMap.WF.empty
+  inputWF := ⟨[], .empty⟩
+  candidate := {
+    nparams := 1
+    kernelTypes := treeKernelTypes
+    numNested := 0
+    isUnsafe := false
+    context := treeKernelContext
+    execution := treeExecution
+    produced := treeProducedExecution.property
+    familyNames := rfl
+    constructorNames := rfl }
+  generationProduced := rfl
+  trace := treeAddInductBlockTrace
+  aligned := tree_verify_aligned
+
+def indexedTreeReplay11 : BlockReplayArtifact where
+  label := ``IndexedTree
+  source := indexedTreeDecl
+  inputMap := natMap
+  inputEnv := natFinalEnv
+  outputMap := indexedReplayMap
+  outputEnv := indexedTreeFinalEnv
+  inputMapWF := nat_aligned.map_wf
+  inputWF := (nat_trEnv' (safety := .safe)).wf
+  candidate := {
+    nparams := 1
+    kernelTypes := indexedTreeKernelTypes
+    numNested := 0
+    isUnsafe := false
+    context := indexedTreeKernelContext
+    execution := indexedTreeExecution
+    produced := indexedTreeProducedExecution.property
+    familyNames := rfl
+    constructorNames := rfl }
+  generationProduced := rfl
+  trace := indexedTreeAddInductBlockTrace
+  aligned := indexedTree_verify_aligned
+
+def mutualReplayMatrix : List BlockReplayArtifact :=
+  [treeReplay11, indexedTreeReplay11]
+
+def roseReplay11 : NestedReplayArtifact where
+  label := ``RoseTree
+  source := roseSourceV
+  inputMap := listMap07
+  inputEnv := listFinalEnv07
+  outputMap := roseMap09
+  outputEnv := roseFinalEnv09
+  inputMapWF := listTrEnv07.map_wf
+  inputWF := listTrEnv07.wf
+  candidate := {
+    targets := [NestedInductiveFixtures.listTarget]
+    nested := roseNestedC
+    produced := by
+      exact (Option.some_get (x := roseNestedC?)
+        (of_decide_eq_true
+          Lean4Lean.NestedReplayFixtures.roseNestedC._native.native_decide.ax_1)).symm }
+  candidateAgrees := rfl
+  trace := roseTrace09
+  aligned := roseTrEnv09.aligned
+
+def nestedIndexedReplay11 : NestedReplayArtifact where
+  label := ``NVTree
+  source := nvSourceV
+  inputMap := pvecCtorMap09
+  inputEnv := pvecCtorEnv09
+  outputMap := nvMap09
+  outputEnv := nvFinalEnv09
+  inputMapWF := pvecTrEnv09.map_wf
+  inputWF := pvecTrEnv09.wf
+  candidate := {
+    targets := [NestedTransformation.pvecStoredTarget]
+    nested := nvNestedC
+    produced := by
+      exact (Option.some_get (x := nvNestedC?)
+        (of_decide_eq_true
+          Lean4Lean.NestedReplayFixtures.nvNestedC._native.native_decide.ax_1)).symm }
+  candidateAgrees := rfl
+  trace := nvTrace09
+  aligned := nvTrEnv09.aligned
+
+/-- A two-parameter target with a second nested occurrence discovered while
+processing the first auxiliary constructor.  The explicit input is the full
+replay of `BiBox`, and all three restored recursors are inserted from actual
+kernel metadata. -/
+def deepNestedReplay11 : NestedReplayArtifact where
+  label := ``DeepBi
+  source := deepSourceV
+  inputMap := biBoxMap
+  inputEnv := biBoxFinalEnv
+  outputMap := deepMap
+  outputEnv := deepFinalEnv
+  inputMapWF := biBoxMapWF
+  inputWF := biBoxFinalWF
+  candidate := {
+    targets := [biBoxTarget]
+    nested := deepNestedC
+    produced := deepNestedC_produced }
+  candidateAgrees := rfl
+  trace := deepTrace
+  aligned := deepTrEnv.aligned
+
+def nestedReplayMatrix : List NestedReplayArtifact :=
+  [roseReplay11, nestedIndexedReplay11, deepNestedReplay11]
+
+/-- The three supported transaction modes in one consumer-facing inventory. -/
+inductive ReplayArtifact where
+  | singleton (artifact : SingletonCandidateReplayArtifact)
+  | block (artifact : BlockReplayArtifact)
+  | nested (artifact : NestedReplayArtifact)
+
+namespace ReplayArtifact
+
+def MetadataComplete : ReplayArtifact → Prop
+  | .singleton artifact => SingletonReplayCompletion artifact.input.replay
+  | .block artifact => artifact.MetadataComplete
+  | .nested artifact => artifact.MetadataComplete
+
+theorem metadataComplete : ∀ artifact : ReplayArtifact,
+    artifact.MetadataComplete
+  | .singleton artifact => artifact.input.replay.completion
+  | .block artifact => artifact.metadataComplete
+  | .nested artifact => artifact.metadataComplete
+
+end ReplayArtifact
+
+/-- Complete actual-metadata matrix: all 20 singleton rows, both mutual rows,
+and all three nested rows, with dependency environments retained per row. -/
+def completeReplayMatrix : List ReplayArtifact :=
+  singletonCandidateReplayMatrix.map .singleton ++
+    mutualReplayMatrix.map .block ++ nestedReplayMatrix.map .nested
+
+example : singletonReplayMatrix.length = 19 := rfl
+example : singletonCandidateReplayMatrix.length = 20 := by native_decide
+example : mutualReplayMatrix.length = 2 := rfl
+example : nestedReplayMatrix.length = 3 := rfl
+example : completeReplayMatrix.length = 25 := by native_decide
+
+theorem completeReplayMatrix_metadataComplete :
+    ∀ artifact ∈ completeReplayMatrix, artifact.MetadataComplete := by
+  intro artifact _
+  exact artifact.metadataComplete
+
+end CompleteInductiveReplay
+
+end Lean4Lean
+
+/-! ## Exact trust manifests -/
+
+/--
+info: 'Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate
+
+/--
+info: 'Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate
+
+/--
+info: 'Lean4Lean.CompleteInductiveReplay.completeReplayMatrix_metadataComplete' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Lean4Lean.ptrEqConstantInfo_eq,
+ Lean4Lean.ptrEqExpr_eq,
+ Quot.sound,
+ Lean.Expr.abstractRange_eq,
+ Lean.Expr.abstract_eq,
+ Lean.Expr.eqv_eq,
+ Lean.Expr.hasLooseBVar_eq,
+ Lean.Expr.instantiate1_eq,
+ Lean.Expr.instantiateRange_eq,
+ Lean.Expr.instantiateRevRange_eq,
+ Lean.Expr.instantiateRev_eq,
+ Lean.Expr.instantiate_eq,
+ Lean.Expr.looseBVarRange_eq,
+ Lean.Expr.lowerLooseBVars_eq,
+ Lean.Expr.mkAppData_eq,
+ Lean.Expr.mkData_eq,
+ Lean.Expr.replace_eq,
+ Lean.Level.hasMVar_eq,
+ Lean.Level.hasParam_eq,
+ Lean.Level.instLawfulBEqLevel,
+ Lean.Level.isExplicitSubsumedAux_eq,
+ Lean.Level.normalize_eq,
+ Lean.PersistentArray.toList'_push,
+ Lean.PersistentHashMap.findAux_isSome,
+ Lean.Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
+ Lean.PersistentHashMap.WF.find?_eq,
+ Lean.PersistentHashMap.WF.toList'_insert,
+ Lean4Lean.CompleteInductiveReplay.singletonCandidateReplayMatrix._native.native_decide.ax_1,
+ Lean4Lean.DeepNestedReplayFixtures.biBoxObservedShape._native.native_decide.ax_1_1,
+ Lean4Lean.DeepNestedReplayFixtures.deepKTarget._native.native_decide.ax_1_1,
+ Lean4Lean.DeepNestedReplayFixtures.deepNestedC_some._native.native_decide.ax_1_1,
+ Lean4Lean.DeepNestedReplayFixtures.deepRecursors_eq._native.native_decide.ax_1_1,
+ Lean4Lean.DeepNestedReplayFixtures.deepRules_eq._native.native_decide.ax_1_1,
+ Lean4Lean.MutualInductiveReplayFixtures.indexedTreeExecutionResult_isOk._native.native_decide.ax_1_1,
+ Lean4Lean.MutualInductiveReplayFixtures.treeExecutionResult_isOk._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.nvKTarget09._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.nvNestedC._native.native_decide.ax_1,
+ Lean4Lean.NestedReplayFixtures.nvRecursors_eq._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.nvRules_eq._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.roseKTarget09._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.roseNestedC._native.native_decide.ax_1,
+ Lean4Lean.NestedReplayFixtures.roseRecursors_eq._native.native_decide.ax_1_1,
+ Lean4Lean.NestedReplayFixtures.roseRules_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms Lean4Lean.CompleteInductiveReplay.completeReplayMatrix_metadataComplete
diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean
index 0af803b9..571de30c 100644
--- a/Lean4Lean/Verify/Environment/Lemmas.lean
+++ b/Lean4Lean/Verify/Environment/Lemmas.lean
@@ -18,23 +18,12 @@ theorem TrDefVal.sf_mono (hsf : safety ≤ safety')
     (H : TrDefVal safety' env ci ci') : TrDefVal safety env ci ci' :=
   ⟨H.1.sf_mono hsf, H.2⟩
 
-theorem TrEnv'.sf_mono (hsf : safety ≤ safety') :
-    TrEnv' safety' C Q env → TrEnv' safety C Q env
-  | .empty => .empty
-  | .axiom htr hfresh hwf hadd H =>
-    .axiom (htr.sf_mono hsf) hfresh hwf hadd (H.sf_mono hsf)
-  | .defn htr hfresh hwf hadd H =>
-    .defn (htr.sf_mono hsf) hfresh hwf hadd (H.sf_mono hsf)
-  | .opaque htr hfresh hwf hadd H =>
-    .opaque (htr.sf_mono hsf) hfresh hwf hadd (H.sf_mono hsf)
-  | .quot hready hadd H =>
-    .quot hready hadd (H.sf_mono hsf)
-  | .inductStaging hadd hwf H =>
-    .inductStaging hadd hwf (H.sf_mono hsf)
-  | .induct hadd H =>
-    .induct hadd (H.sf_mono hsf)
-  | .inductBlock hadd H =>
-    .inductBlock hadd (H.sf_mono hsf)
+/- The former blanket `TrEnv'.sf_mono` was deleted at the v4.33
+reconciliation: upstream's new `TrEnv'.ignore` constructor makes lowering the
+safety mode of an arbitrary translation unsound (a declaration skipped at a
+strict mode must be translated, not skipped, at a laxer one). Fixture
+environments that need every safety mode now state their `TrEnv'` derivations
+parametrically in `safety` instead. -/
 
 theorem TrConstant.mono {env env' : VEnv} (henv : env ≤ env')
     (H : TrConstant safety env ci ci') : TrConstant safety env' ci ci' :=
@@ -56,6 +45,7 @@ inductive Aligned : ConstMap → VEnv → Prop where
   | const : Aligned C venv → C.find? n = none → TrConstant safety venv ci ci' →
     venv.addConst n ci' = some venv' → ci.name = n → Aligned (C.insert n ci) venv'
   | defeq : Aligned C venv → Aligned C (venv.addDefEq df)
+  | structEta : Aligned C venv → Aligned C (venv.addStructEta rule)
 
 theorem Aligned.map_wf (H : Aligned safety C venv) : C.WF := by
   induction H with
@@ -63,6 +53,7 @@ theorem Aligned.map_wf (H : Aligned safety C venv) : C.WF := by
   | ignoreConst _ h1 _ _ ih
   | const _ h1 _ _ _ ih => exact ih.insert _ _ h1
   | defeq _ ih => exact ih
+  | structEta _ ih => exact ih
 
 theorem Aligned.find?_iff (H : Aligned safety C venv) :
     (∃ ci, C.find? name = some ci ∧ safety ≤ ci.safety) ↔ ∃ ci, venv.constants name = some ci := by
@@ -76,6 +67,7 @@ theorem Aligned.find?_iff (H : Aligned safety C venv) :
     simp [VEnv.addConst] at eq; split at eq <;> cases eq
     split <;> simp_all; exact h2.1
   | defeq _ ih => exact ih
+  | structEta _ ih => exact ih
 
 theorem Aligned.addQuot1 {Q : Prop}
     (H1 : ∀ c env, Aligned safety c env → P c env → Q)
@@ -94,6 +86,31 @@ theorem AddInductConstant.map_wf
   rw [H.map_add]
   exact wf.insert _ _ H.map_fresh
 
+/-- The implementation metadata inserted by one inductive-constant step is
+still available at that step's output boundary. -/
+theorem AddInductConstant.map_lookup
+    (H : AddInductConstant kind C₁ env₁ ci C₂ env₂)
+    (wf : C₁.WF) : C₂.find? ci.name = some H.info := by
+  simpa [H.map_add, wf.find?_insert]
+
+/-- An inductive-metadata insertion preserves every lookup already present in
+the input map.  Freshness rules out the only key at which `insert` could
+replace that entry. -/
+theorem AddInductConstant.preserve_map_lookup
+    (H : AddInductConstant kind C₁ env₁ ci' C₂ env₂)
+    (wf : C₁.WF) {name : Name} {info : ConstantInfo}
+    (hlookup : C₁.find? name = some info) :
+    C₂.find? name = some info := by
+  rw [H.map_add, wf.find?_insert]
+  split
+  · rename_i heq
+    have hname : ci'.name = name := by simpa using heq
+    subst name
+    have hfresh := H.map_fresh
+    rw [hlookup] at hfresh
+    contradiction
+  · exact hlookup
+
 theorem InductConstantKind.Matches.deltaValue?_eq_none
     {kind : InductConstantKind} {ci : ConstantInfo}
     (H : InductConstantKind.Matches kind ci) : ci.deltaValue? = none := by
@@ -119,6 +136,34 @@ theorem AddInductConstants.map_wf :
   | .nil, wf => wf
   | .cons h hrest, wf => hrest.map_wf (h.map_wf wf)
 
+/-- A whole insertion fold preserves every lookup from its input map. -/
+theorem AddInductConstants.preserve_map_lookup
+    (H : AddInductConstants kind C₁ env₁ cis C₂ env₂)
+    (wf : C₁.WF) {name : Name} {info : ConstantInfo}
+    (hlookup : C₁.find? name = some info) :
+    C₂.find? name = some info := by
+  induction H with
+  | nil => exact hlookup
+  | cons h hrest ih =>
+    exact ih (h.map_wf wf) (h.preserve_map_lookup wf hlookup)
+
+/-- Final-map evidence for any member of an inductive metadata fold.  The
+result retains the exact implementation object, its role tag, and its
+translation against the final Theory environment. -/
+theorem AddInductConstants.translated_lookup
+    (H : AddInductConstants kind C₁ env₁ cis C₂ env₂)
+    (wf : C₁.WF) {ci : VConstVal} (hmem : ci ∈ cis) : ∃ info,
+      C₂.find? ci.name = some info ∧
+      kind.Matches info ∧ TrConstVal .safe env₂ info ci := by
+  induction H with
+  | nil => contradiction
+  | cons h hrest ih =>
+    rcases List.mem_cons.1 hmem with rfl | hmem
+    · refine ⟨h.info, ?_, h.kind_eq, ?_⟩
+      exact hrest.preserve_map_lookup (h.map_wf wf) (h.map_lookup wf)
+      exact h.tr.mono (h.le.trans hrest.le)
+    · exact ih (h.map_wf wf) hmem
+
 theorem AddInductConstants.old_of_value :
     (H : AddInductConstants kind C₁ env₁ cis C₂ env₂) → C₁.WF →
     C₂.find? name = some ci → ci.deltaValue? = some v → C₁.find? name = some ci
@@ -126,6 +171,141 @@ theorem AddInductConstants.old_of_value :
   | .cons h hrest, wf, hout, hv =>
     h.old_of_value wf (hrest.old_of_value (h.map_wf wf) hout hv) hv
 
+/-! ## Final translated metadata inventories -/
+
+/-- Final-map and final-environment evidence for the family emitted by a
+singleton inductive replay. -/
+theorem AddInductTrace.type_translated_lookup
+    (H : AddInductTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) :
+    ∃ info,
+      C₂.find? H.generation.block.sourceType.name = some info ∧
+      InductConstantKind.induct.Matches info ∧
+      TrConstVal .safe env₂ info H.generation.block.sourceType.toVConstVal := by
+  refine ⟨H.addType.info, ?_, H.addType.kind_eq, ?_⟩
+  · exact H.addRec.preserve_map_lookup
+      (H.addCtors.map_wf (H.addType.map_wf wf))
+      (H.addCtors.preserve_map_lookup (H.addType.map_wf wf)
+        (H.addType.map_lookup wf))
+  · exact H.addType.tr.mono
+      (H.addType.le.trans <| H.addCtors.le.trans <|
+        H.addRec.le.trans H.addRules.le)
+
+/-- Final-map and final-environment evidence for every constructor emitted by
+a singleton inductive replay. -/
+theorem AddInductTrace.constructor_translated_lookup
+    (H : AddInductTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ H.generation.block.sourceType.ctors) :
+    ∃ info,
+      C₂.find? constructor.name = some info ∧
+      InductConstantKind.ctor.Matches info ∧
+      TrConstVal .safe env₂ info constructor := by
+  obtain ⟨info, hlookup, hkind, htr⟩ :=
+    H.addCtors.translated_lookup (H.addType.map_wf wf) hconstructor
+  exact ⟨info,
+    H.addRec.preserve_map_lookup (H.addCtors.map_wf (H.addType.map_wf wf)) hlookup,
+    hkind, htr.mono (H.addRec.le.trans H.addRules.le)⟩
+
+/-- Final-map and final-environment evidence for the recursor emitted by a
+singleton inductive replay. -/
+theorem AddInductTrace.recursor_translated_lookup
+    (H : AddInductTrace C₁ env₁ decl C₂ env₂)
+    (wf : C₁.WF) : ∃ info,
+      C₂.find? (inductGenerationRecVal H.generation).name = some info ∧
+      InductConstantKind.recursor.Matches info ∧
+      TrConstVal .safe env₂ info (inductGenerationRecVal H.generation) := by
+  exact ⟨H.addRec.info, H.addRec.map_lookup
+      (H.addCtors.map_wf (H.addType.map_wf wf)), H.addRec.kind_eq,
+    H.addRec.tr.mono (H.addRec.le.trans H.addRules.le)⟩
+
+/-- Final translated lookup for every source family in a mutual block. -/
+theorem AddInductBlockTrace.family_translated_lookup
+    (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {family : VInductiveType} (hfamily : family ∈ decl.types) : ∃ info,
+      C₂.find? family.name = some info ∧
+      InductConstantKind.induct.Matches info ∧
+      TrConstVal .safe env₂ info family.toVConstVal := by
+  have hmember : family.toVConstVal ∈ decl.blockTypeConstants :=
+    List.mem_map.2 ⟨family, hfamily, rfl⟩
+  obtain ⟨info, hlookup, hkind, htr⟩ :=
+    H.addTypes.translated_lookup wf hmember
+  exact ⟨info,
+    H.addRecs.preserve_map_lookup
+      (H.addCtors.map_wf (H.addTypes.map_wf wf))
+      (H.addCtors.preserve_map_lookup (H.addTypes.map_wf wf) hlookup),
+    hkind, htr.mono (H.addCtors.le.trans <| H.addRecs.le.trans H.addRules.le)⟩
+
+/-- Final translated lookup for every flattened constructor in a mutual
+block. -/
+theorem AddInductBlockTrace.constructor_translated_lookup
+    (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ decl.blockConstructorConstants) : ∃ info,
+      C₂.find? constructor.name = some info ∧
+      InductConstantKind.ctor.Matches info ∧
+      TrConstVal .safe env₂ info constructor := by
+  obtain ⟨info, hlookup, hkind, htr⟩ :=
+    H.addCtors.translated_lookup (H.addTypes.map_wf wf) hconstructor
+  exact ⟨info,
+    H.addRecs.preserve_map_lookup
+      (H.addCtors.map_wf (H.addTypes.map_wf wf)) hlookup,
+    hkind, htr.mono (H.addRecs.le.trans H.addRules.le)⟩
+
+/-- Final translated lookup for every generated recursor in a mutual block. -/
+theorem AddInductBlockTrace.recursor_translated_lookup
+    (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {recursor : VConstVal} (hrecursor : recursor ∈ H.generation.recursors) :
+    ∃ info,
+      C₂.find? recursor.name = some info ∧
+      InductConstantKind.recursor.Matches info ∧
+      TrConstVal .safe env₂ info recursor := by
+  obtain ⟨info, hlookup, hkind, htr⟩ := H.addRecs.translated_lookup
+    (H.addCtors.map_wf (H.addTypes.map_wf wf)) hrecursor
+  exact ⟨info, hlookup, hkind, htr.mono H.addRules.le⟩
+
+/-- Final translated lookup for every source family in a nested replay. -/
+theorem AddInductNestedTrace.family_translated_lookup
+    (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {family : VInductiveType} (hfamily : family ∈ decl.types) : ∃ info,
+      C₂.find? family.name = some info ∧
+      InductConstantKind.induct.Matches info ∧
+      TrConstVal .safe env₂ info family.toVConstVal := by
+  have hmember : family.toVConstVal ∈ decl.blockTypeConstants :=
+    List.mem_map.2 ⟨family, hfamily, rfl⟩
+  obtain ⟨info, hlookup, hkind, htr⟩ :=
+    H.addTypes.translated_lookup wf hmember
+  exact ⟨info,
+    H.addRecs.preserve_map_lookup
+      (H.addCtors.map_wf (H.addTypes.map_wf wf))
+      (H.addCtors.preserve_map_lookup (H.addTypes.map_wf wf) hlookup),
+    hkind, htr.mono (H.addCtors.le.trans <| H.addRecs.le.trans H.addRules.le)⟩
+
+/-- Final translated lookup for every source constructor in a nested replay. -/
+theorem AddInductNestedTrace.constructor_translated_lookup
+    (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {constructor : VConstVal}
+    (hconstructor : constructor ∈ decl.blockConstructorConstants) : ∃ info,
+      C₂.find? constructor.name = some info ∧
+      InductConstantKind.ctor.Matches info ∧
+      TrConstVal .safe env₂ info constructor := by
+  obtain ⟨info, hlookup, hkind, htr⟩ :=
+    H.addCtors.translated_lookup (H.addTypes.map_wf wf) hconstructor
+  exact ⟨info,
+    H.addRecs.preserve_map_lookup
+      (H.addCtors.map_wf (H.addTypes.map_wf wf)) hlookup,
+    hkind, htr.mono (H.addRecs.le.trans H.addRules.le)⟩
+
+/-- Final translated lookup for every restored recursor in a nested replay. -/
+theorem AddInductNestedTrace.recursor_translated_lookup
+    (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF)
+    {recursor : VConstVal} (hrecursor : recursor ∈ H.nested.recursors) : ∃ info,
+      C₂.find? recursor.name = some info ∧
+      InductConstantKind.recursor.Matches info ∧
+      TrConstVal .safe env₂ info recursor := by
+  obtain ⟨info, hlookup, hkind, htr⟩ := H.addRecs.translated_lookup
+    (H.addCtors.map_wf (H.addTypes.map_wf wf)) hrecursor
+  exact ⟨info, hlookup, hkind, htr.mono H.addRules.le⟩
+
 theorem AddInduct.map_wf (H : AddInduct C₁ env₁ decl C₂ env₂)
     (wf : C₁.WF) : C₂.WF := by
   rcases H with ⟨H⟩
@@ -158,6 +338,24 @@ theorem AddInductBlock.old_of_value
     (H.addCtors.old_of_value wfTypes
       (H.addRecs.old_of_value wfCtors hout hv) hv) hv
 
+theorem AddInductNested.map_wf
+    (H : AddInductNested C₁ env₁ decl C₂ env₂)
+    (wf : C₁.WF) : C₂.WF := by
+  rcases H with ⟨H⟩
+  exact H.addRecs.map_wf <| H.addCtors.map_wf <|
+    H.addTypes.map_wf wf
+
+theorem AddInductNested.old_of_value
+    (H : AddInductNested C₁ env₁ decl C₂ env₂)
+    (wf : C₁.WF) (hout : C₂.find? name = some ci)
+    (hv : ci.deltaValue? = some v) : C₁.find? name = some ci := by
+  rcases H with ⟨H⟩
+  have wfTypes := H.addTypes.map_wf wf
+  have wfCtors := H.addCtors.map_wf wfTypes
+  exact H.addTypes.old_of_value wf
+    (H.addCtors.old_of_value wfTypes
+      (H.addRecs.old_of_value wfCtors hout hv) hv) hv
+
 theorem Aligned.addInductConstant
     (wf : Aligned safety C₁ env₁)
     (H : AddInductConstant kind C₁ env₁ ci C₂ env₂) : Aligned safety C₂ env₂ := by
@@ -196,31 +394,91 @@ theorem Aligned.addInductBlock
   have wfRecs := wfCtors.addInductConstants H.addRecs
   exact wfRecs.addDefEqFold _
 
+theorem Aligned.addInductNested
+    (H : AddInductNested C₁ env₁ decl C₂ env₂)
+    (wf : Aligned safety C₁ env₁) : Aligned safety C₂ env₂ := by
+  rcases H with ⟨H⟩
+  rw [← H.addRules.to_add]
+  have wfTypes := wf.addInductConstants H.addTypes
+  have wfCtors := wfTypes.addInductConstants H.addCtors
+  have wfRecs := wfCtors.addInductConstants H.addRecs
+  exact wfRecs.addDefEqFold _
+
 /--
-info: 'Lean4Lean.Aligned.addInduct' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.Aligned.addInduct' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms Aligned.addInduct
 
 /--
-info: 'Lean4Lean.Aligned.addInductBlock' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.Aligned.addInductBlock' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms Aligned.addInductBlock
 
+theorem Aligned.addDefEqs {C : ConstMap} : ∀ {cis' : List VDefVal} {venv},
+    Aligned safety C venv → Aligned safety C (venv.addDefEqs cis')
+  | [], _, H => H
+  | ci :: cis, venv, H => by
+    show Aligned safety C (VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis)
+    exact Aligned.addDefEqs H.defeq
+
+theorem Aligned.insertDefs : ∀ {cis : List DefinitionVal} {cis' : List VDefVal} {C venv venv'},
+    Aligned safety C venv → (cis.map (·.name)).Nodup →
+    (∀ ci ∈ cis, C.find? ci.name = none) →
+    List.Forall₂ (fun ci ci' => TrConstVal safety venv (.defnInfo ci) ci'.toVConstVal) cis cis' →
+    venv.addConsts cis' = some venv' → Aligned safety (insertDefs C cis) venv'
+  | [], _, _, _, _, H, _, _, hblk, e => by
+    cases hblk; simp [VEnv.addConsts] at e; cases e; exact H
+  | ci :: cis, _, C, venv, _, H, hnd, hfr, hblk, e => by
+    cases hblk with | @cons _ ci' _ _ htr hblk => ?_
+    simp [VEnv.addConsts, Option.bind_eq_some_iff] at e
+    obtain ⟨venv₁, h1, h2⟩ := e
+    have hname := htr.2
+    simp only [ConstantInfo.name, ConstantInfo.toConstantVal] at hname
+    simp only [List.map_cons, List.nodup_cons, List.mem_map] at hnd
+    have h1' : venv.addConst ci.name ci'.toVConstant = some venv₁ := by rw [hname]; exact h1
+    show Aligned safety
+      (_root_.Lean4Lean.insertDefs (SMap.insert C ci.name (.defnInfo ci)) cis) _
+    refine Aligned.insertDefs (H.const (hfr _ (.head _)) htr.1 h1' rfl) hnd.2
+      (fun c hc => ?_) (Lean4Lean.List.Forall₂.imp
+        (fun _ _ h => h.mono (VEnv.addConst_le h1')) hblk) h2
+    rw [H.map_wf.find?_insert]
+    have : ¬ (ci.name == c.name) = true := by
+      simp only [beq_iff_eq]; intro h
+      exact hnd.1 ⟨c, hc, h.symm⟩
+    simp [this]
+    exact hfr c (.tail _ hc)
+
 theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := by
   induction H with
   | empty => exact .empty
+  | ignore h1 h2 _ ih => exact ih.ignoreConst h1 h2 rfl
   | «axiom» h1 h2 _ h _ ih => exact ih.const h2 h1 h rfl
+  | thm h1 h2 _ _ h _ ih => exact ih.const h2 h1.1.1 h rfl
   | «opaque» h1 h2 _ h _ ih => exact ih.const h2 h1.1.1 h rfl
   | defn h1 h2 _ h _ ih => exact (ih.const h2 h1.1.1 h rfl).defeq
+  | mutualDef hblk hnd hfr _ hadd _ _ ih =>
+    exact Aligned.addDefEqs <| ih.insertDefs hnd hfr
+      (Lean4Lean.List.Forall₂.imp (fun _ _ h => h.1) hblk) hadd
   | quot _ h _ ih => exact ih.addQuot h
   | inductStaging h _ _ ih => exact ih.addInductConstant h
   | induct h _ ih => exact ih.addInduct h
   | inductBlock h _ ih => exact ih.addInductBlock h
+  | inductNested h _ ih => exact ih.addInductNested h
+  | structEta _ _ ih => exact ih.structEta
 
+/- Since the v4.33 reconciliation the `mutualDef` arm routes through
+`insertDefs`, whose `SMap` reasoning uses the classified persistent-map
+container contracts; the closure is pinned so any further growth is
+reviewed. -/
 /--
-info: 'Lean4Lean.TrEnv'.aligned' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TrEnv'.aligned' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ PersistentHashMap.findAux_isSome,
+ PersistentHashMap.WF.find?_eq,
+ PersistentHashMap.WF.toList'_insert]
 -/
 #guard_msgs in
 #print axioms TrEnv'.aligned
@@ -248,6 +506,9 @@ theorem Aligned.find? (H : Aligned safety C venv)
       simp; rename_i h'; refine h2.mono this
     · let ⟨_, h1, h2⟩ := ih h; exact ⟨_, this.constants h1, h2.mono this⟩
   | defeq h1 ih => let ⟨_, h1, h2⟩ := ih h; exact ⟨_, h1, h2.mono VEnv.addDefEq_le⟩
+  | structEta h1 ih =>
+    let ⟨_, h1, h2⟩ := ih h
+    exact ⟨_, h1, h2.mono VEnv.addStructEta_le⟩
 
 theorem Aligned.find?_uniq (H : Aligned safety C venv)
     (h : C.find? name = some ci) (hs : venv.constants name = some ci') :
@@ -266,6 +527,9 @@ theorem Aligned.find?_uniq (H : Aligned safety C venv)
     · rintro ⟨⟩ ⟨⟩; rename_i n _ _ _; subst n; exact ⟨h4, h2.mono this⟩
     · intro hs h; let ⟨h1, h2⟩ := ih h hs; exact ⟨h1, h2.mono this⟩
   | defeq h1 ih => let ⟨h1, h2⟩ := ih h hs; exact ⟨h1, h2.mono VEnv.addDefEq_le⟩
+  | structEta h1 ih =>
+    let ⟨h1, h2⟩ := ih h hs
+    exact ⟨h1, h2.mono VEnv.addStructEta_le⟩
 
 theorem TrEnv.find?_iff (H : TrEnv safety env venv) :
     (∃ ci, env.find? name = some ci ∧ safety ≤ ci.safety) ↔ ∃ ci, venv.constants name = some ci := by
@@ -287,6 +551,41 @@ theorem TrEnv.find?_uniq (H : TrEnv safety env venv)
     ci.name = name ∧ TrConstant safety venv ci ci' :=
   H.aligned.find?_uniq (H.map_wf.find?'_eq_find? _ ▸ h) hs
 
+theorem VEnv.addDefEqs_le : ∀ {cis' : List VDefVal} {venv : VEnv}, venv ≤ venv.addDefEqs cis'
+  | [], _ => .rfl
+  | ci :: cis, venv => by
+    show venv ≤ VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis
+    exact VEnv.addDefEq_le.trans VEnv.addDefEqs_le
+
+theorem VEnv.addDefEqs_self : ∀ {cis' : List VDefVal} {venv : VEnv} {ci'}, ci' ∈ cis' →
+    (venv.addDefEqs cis').defeqs ci'.toDefEq
+  | ci :: cis, venv, _, hc => by
+    show (VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis).defeqs _
+    cases hc with
+    | head => exact VEnv.addDefEqs_le.defeqs VEnv.addDefEq_self
+    | tail _ hc => exact VEnv.addDefEqs_self hc
+
+theorem insertDefs_find? : ∀ {cis : List DefinitionVal} {C : ConstMap} {name ci}, C.WF →
+    (∀ d ∈ cis, C.find? d.name = none) → (cis.map (·.name)).Nodup →
+    (insertDefs C cis).find? name = some ci →
+    C.find? name = some ci ∨ ∃ d ∈ cis, d.name = name ∧ ConstantInfo.defnInfo d = ci
+  | [], _, _, _, _, _, _, h => .inl h
+  | d :: ds, C, name, ci, hC, hfr, hnd, h => by
+    simp only [List.map_cons, List.nodup_cons, List.mem_map] at hnd
+    have hfr' : ∀ e ∈ ds, (SMap.insert C d.name (.defnInfo d)).find? e.name = none := by
+      intro e he
+      rw [hC.find?_insert]
+      have : ¬ (d.name == e.name) = true := by
+        simp only [beq_iff_eq]; intro hh; exact hnd.1 ⟨e, he, hh.symm⟩
+      simp [this]; exact hfr e (.tail _ he)
+    have h : (insertDefs (SMap.insert C d.name (.defnInfo d)) ds).find? name = some ci := h
+    rcases insertDefs_find? (hC.insert _ _ (hfr _ (.head _))) hfr' hnd.2 h with h | ⟨e, he, h1, h2⟩
+    · rw [hC.find?_insert] at h; split at h
+      · rename_i hb; cases h
+        exact .inr ⟨d, .head _, by simpa using hb, rfl⟩
+      · exact .inl h
+    · exact .inr ⟨e, .tail _ he, h1, h2⟩
+
 theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci)
     (hs : safety ≤ ci.safety) (hv : ci.deltaValue? = some v) :
     TrExpr venv ci.levelParams [] v (.const ci.name (VLevel.params ci.levelParams.length)) := by
@@ -296,7 +595,11 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci
     rw [hC.find?_insert]; simp; split <;> simp +contextual [*]
   induction H with
   | empty => simp [SMap.find?] at h
-  | «axiom» _ _ _ h1 H ih | «opaque» _ _ _ h1 H ih =>
+  | ignore h1 h2 H ih =>
+    obtain h | ⟨rfl, rfl⟩ := this H.map_wf h
+    · exact ih h
+    · exact (h2 hs).elim
+  | «axiom» _ _ _ h1 H ih =>
     obtain h | ⟨rfl, rfl⟩ := this H.map_wf h
     · exact (ih h).mono (VEnv.addConst_le h1)
     · contradiction
@@ -309,6 +612,33 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci
         (H.defn h2 h3 h4 h1).wf.ordered.defEqWF VEnv.addDefEq_self
       let ⟨⟨⟨b1, b2, b3⟩, b4⟩, b5⟩ := h2
       refine ⟨_, b5.mono le, b2.symm ▸ b4.symm ▸ ⟨_, this.symm⟩⟩
+  | mutualDef hblk hnd hfr _ hadd _ H ih =>
+    have' le := (VEnv.addConsts_le hadd).trans VEnv.addDefEqs_le
+    rcases insertDefs_find? H.map_wf hfr hnd h with h | ⟨d, hd, rfl, rfl⟩
+    · exact (ih h).mono le
+    · obtain ⟨d', hd', htr, hval⟩ := Lean4Lean.List.Forall₂.forall_exists_l hblk _ hd
+      cases hv
+      have hdefeq := VEnv.IsDefEq.extra0 (VEnv.addDefEqs_self hd')
+        ((H.mutualDef hblk hnd hfr ‹_› hadd ‹_›).wf.ordered.defEqWF (VEnv.addDefEqs_self hd'))
+      let ⟨⟨b1, b2, b3⟩, b4⟩ := htr
+      exact ⟨_, hval.mono VEnv.addDefEqs_le, b2.symm ▸ b4.symm ▸ ⟨_, hdefeq.symm⟩⟩
+  | thm h2 h3 h4 h5 h1 H ih =>
+    have' le := VEnv.addConst_le h1
+    obtain h | ⟨rfl, rfl⟩ := this H.map_wf h
+    · exact (ih h).mono le
+    · cases hv
+      let ⟨⟨⟨b1, b2, b3⟩, b4⟩, b5⟩ := h2
+      dsimp only [ConstantInfo.name, ConstantInfo.levelParams, ConstantInfo.toConstantVal] at b2 b4 ⊢
+      have hp := h5.mono le
+      have hb := h4.mono le
+      have hc := VEnv.HasType.const0 (VEnv.addConst_self h1) ⟨_, hp⟩
+      rw [b4] at hc
+      refine ⟨_, b5.mono le, b2.symm ▸ b4.symm ▸ ?_⟩
+      exact ⟨_, .proofIrrel hp hb hc⟩
+  | «opaque» _ _ _ h1 H ih =>
+    obtain h | ⟨rfl, rfl⟩ := this H.map_wf h
+    · exact (ih h).mono (VEnv.addConst_le h1)
+    · contradiction
   | quot _ h1 H ih =>
     suffices ∀ {n k ci' P}, (∀ C env, Aligned safety C env → P C env → C.find? name = some ci) →
         ∀ C env, Aligned safety C env → AddQuot1 n k ci' P C env → C.find? name = some ci by
@@ -325,6 +655,10 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci
     exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le
   | inductBlock h1 H ih =>
     exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le
+  | inductNested h1 H ih =>
+    exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le
+  | structEta _ H ih =>
+    exact (ih h).mono VEnv.addStructEta_le
 
 nonrec theorem TrEnv.of_value (H : TrEnv safety env venv) (h : env.find? name = some ci)
     (hs : safety ≤ ci.safety) (hv : ci.deltaValue? = some v) :
diff --git a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean
index 32f09cb3..3af49f5f 100644
--- a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean
+++ b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean
@@ -574,6 +574,11 @@ theorem treeStage :
     VEnv.empty.stageInductiveTypes treeDecl.types = some treeBlockEnv := by
   rfl
 
+theorem empty_le_treeBlockEnv : VEnv.empty ≤ treeBlockEnv where
+  constants h := by simp [VEnv.empty] at h
+  defeqs h := h.elim
+  structEtas h := h.elim
+
 theorem treeFamilyTypeWF (type : VInductiveType)
     (h : type = treeType ∨ type = treeListType) :
     type.type.WF VEnv.empty type.uvars [] := by
@@ -636,7 +641,7 @@ theorem treeLeafSemantic :
   rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[0]).resultIndices =
       [] by rfl]
   exact ⟨⟨⟨.succ (.param 0), .bvar .zero,
-    .inr (VLevel.le_refl _)⟩, trivial⟩, rfl⟩
+    .inr (VLevel.le_refl _)⟩, trivial⟩, .nil⟩
 
 theorem treeNodeSemantic :
     let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[1]
@@ -659,7 +664,7 @@ theorem treeNodeSemantic :
         indices := [] } : RecArg)] by rfl]
   rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[1]).resultIndices =
       [] by rfl]
-  exact ⟨⟨⟨rfl, trivial, rfl⟩, trivial⟩, rfl⟩
+  exact ⟨⟨⟨rfl, trivial, .nil⟩, trivial⟩, .nil⟩
 
 theorem treeBranchSemantic :
     let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[2]
@@ -684,9 +689,9 @@ theorem treeBranchSemantic :
   rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[2]).resultIndices =
       [] by rfl]
   exact ⟨
-    ⟨⟨rfl, ⟨⟨⟨.succ (.param 0), .bvar .zero⟩, trivial⟩, rfl⟩⟩,
+    ⟨⟨rfl, ⟨⟨⟨.succ (.param 0), .bvar .zero⟩, trivial⟩, .nil⟩⟩,
       trivial⟩,
-    rfl⟩
+    .nil⟩
 
 theorem treeListNilSemantic :
     let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[0]
@@ -705,7 +710,7 @@ theorem treeListNilSemantic :
       [] by rfl]
   rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[0]).resultIndices =
       [] by rfl]
-  exact ⟨trivial, rfl⟩
+  exact ⟨trivial, .nil⟩
 
 theorem treeListConsSemantic :
     let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[1]
@@ -735,9 +740,9 @@ theorem treeListConsSemantic :
   rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[1]).resultIndices =
       [] by rfl]
   exact ⟨
-    ⟨⟨rfl, trivial, rfl⟩,
-      ⟨⟨rfl, trivial, rfl⟩, trivial⟩⟩,
-    rfl⟩
+    ⟨⟨rfl, trivial, .nil⟩,
+      ⟨⟨rfl, trivial, .nil⟩, trivial⟩⟩,
+    .nil⟩
 
 theorem treeCheckedBlockWF :
     treeChecked.WF VEnv.empty (.succ (.param 0)) := by
@@ -875,8 +880,7 @@ theorem indexedTreeLeafSemantic :
         some InductiveFixtures.natType.toVConstant := rfl
     have hZero : natFinalEnv.constants ``Nat.zero =
         some InductiveFixtures.natType.ctors[0].toVConstant := rfl
-    exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-      (by type_tac), rfl⟩
+    exact .cons (by type_tac) .nil
 
 theorem indexedTreeNodeSemantic :
     let constructor := CheckedCtor.ofBlock indexedTreeDecl
@@ -914,10 +918,8 @@ theorem indexedTreeNodeSemantic :
   refine ⟨?_, ?_⟩
   · refine ⟨⟨.succ .zero, (by type_tac),
         .inr (VLevel.succ_le_succ VLevel.zero_le)⟩, ?_⟩
-    exact ⟨⟨rfl, trivial, ⟨.const ``Nat [],
-      .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, trivial⟩
-  · exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-      (by type_tac), rfl⟩
+    exact ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, trivial⟩
+  · exact .cons (by type_tac) .nil
 
 theorem indexedTreeListNilSemantic :
     let constructor := CheckedCtor.ofBlock indexedTreeDecl
@@ -945,8 +947,7 @@ theorem indexedTreeListNilSemantic :
       some InductiveFixtures.natType.toVConstant := rfl
   have hZero : natFinalEnv.constants ``Nat.zero =
       some InductiveFixtures.natType.ctors[0].toVConstant := rfl
-  exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-    (by type_tac), rfl⟩
+  exact .cons (by type_tac) .nil
 
 theorem indexedTreeListConsSemantic :
     let constructor := CheckedCtor.ofBlock indexedTreeDecl
@@ -992,12 +993,9 @@ theorem indexedTreeListConsSemantic :
   refine ⟨?_, ?_⟩
   · refine ⟨⟨.succ .zero, (by type_tac),
         .inr (VLevel.succ_le_succ VLevel.zero_le)⟩, ?_⟩
-    refine ⟨⟨rfl, trivial, ⟨.const ``Nat [],
-      .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, ?_⟩
-    exact ⟨⟨rfl, trivial, ⟨.const ``Nat [],
-      .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, trivial⟩
-  · exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-      (by type_tac), rfl⟩
+    refine ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, ?_⟩
+    exact ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, trivial⟩
+  · exact .cons (by type_tac) .nil
 
 theorem indexedTreeCheckedBlockWF :
     indexedTreeChecked.WF natFinalEnv (.succ (.param 0)) := by
@@ -1106,7 +1104,7 @@ theorem treeLeafGenerationWF :
   · intro recursive hrecursive
     change recursive ∈ [] at hrecursive
     nomatch hrecursive
-  · exact treeLeafSemantic.2
+  · exact treeLeafSemantic.2.mono empty_le_treeBlockEnv
 
 theorem treeNodeGenerationWF :
     NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[1]
@@ -1160,8 +1158,8 @@ theorem treeNodeGenerationWF :
     refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩
     · exact .tail _ (.head _)
     · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 0), rfl, rfl⟩
-    · exact ⟨trivial, rfl⟩
-  · exact treeNodeSemantic.2
+    · exact ⟨trivial, .nil⟩
+  · exact treeNodeSemantic.2.mono empty_le_treeBlockEnv
 
 theorem treeBranchGenerationWF :
     NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[2]
@@ -1202,7 +1200,7 @@ theorem treeBranchGenerationWF :
     emittedResult := hresult
     owner := ?_
     recursive := ?_
-    resultSpine := treeBranchSemantic.2 }
+    resultSpine := treeBranchSemantic.2.mono empty_le_treeBlockEnv }
   · refine ⟨treeGeneration.families[0], ?_, rfl, rfl, rfl⟩
     exact .head _
   · intro recursive hrecursive
@@ -1217,7 +1215,7 @@ theorem treeBranchGenerationWF :
     · exact .tail _ (.head _)
     · exact ⟨.forallE (.bvar 0)
         (.app (.const ``TreeList [.param 0]) (.bvar 1)), rfl, rfl⟩
-    · exact ⟨⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩, rfl⟩
+    · exact ⟨⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩, .nil⟩
 
 theorem treeListNilGenerationWF :
     NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[3]
@@ -1243,7 +1241,7 @@ theorem treeListNilGenerationWF :
     emittedResult := hresult
     owner := ?_
     recursive := ?_
-    resultSpine := treeListNilSemantic.2 }
+    resultSpine := treeListNilSemantic.2.mono empty_le_treeBlockEnv }
   · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩
     exact .tail _ (.head _)
   · intro recursive hrecursive
@@ -1292,7 +1290,7 @@ theorem treeListConsGenerationWF :
     emittedResult := hresult
     owner := ?_
     recursive := ?_
-    resultSpine := treeListConsSemantic.2 }
+    resultSpine := treeListConsSemantic.2.mono empty_le_treeBlockEnv }
   · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩
     exact .tail _ (.head _)
   · intro recursive hrecursive
@@ -1310,11 +1308,11 @@ theorem treeListConsGenerationWF :
     · refine ⟨treeGeneration.families[0], ?_, rfl, ?_, ?_⟩
       · exact .head _
       · exact ⟨.app (.const ``Tree [.param 0]) (.bvar 0), rfl, rfl⟩
-      · exact ⟨trivial, rfl⟩
+      · exact ⟨trivial, .nil⟩
     · refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩
       · exact .tail _ (.head _)
       · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 1), rfl, rfl⟩
-      · exact ⟨trivial, rfl⟩
+      · exact ⟨trivial, .nil⟩
 
 theorem treeBlockGenerationWF :
     treeGeneration.WF VEnv.empty treeBlockEnv := by
@@ -1531,8 +1529,7 @@ theorem indexedTreeNodeGenerationWF :
         (.app (.const ``IndexedTreeList [.param 0]) (.bvar 1))
         (.bvar 0), rfl, rfl⟩
     · refine ⟨trivial, ?_⟩
-      exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-        VEnv.HasType.bvar .zero, rfl⟩
+      exact .cons (VEnv.HasType.bvar .zero) .nil
 
 theorem indexedTreeListConsGenerationWF :
     NormalizedBlockCtor.WF indexedTreeGeneration
@@ -1628,16 +1625,14 @@ theorem indexedTreeListConsGenerationWF :
           (.app (.const ``IndexedTree [.param 0]) (.bvar 1))
           (.bvar 0), rfl, rfl⟩
       · refine ⟨trivial, ?_⟩
-        exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-          VEnv.HasType.bvar .zero, rfl⟩
+        exact .cons (VEnv.HasType.bvar .zero) .nil
     · refine ⟨indexedTreeGeneration.families[1], ?_, rfl, ?_, ?_⟩
       · exact .tail _ (.head _)
       · exact ⟨.app
           (.app (.const ``IndexedTreeList [.param 0]) (.bvar 2))
           (.bvar 1), rfl, rfl⟩
       · refine ⟨trivial, ?_⟩
-        exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl,
-          VEnv.HasType.bvar (.succ .zero), rfl⟩
+        exact .cons (VEnv.HasType.bvar (.succ .zero)) .nil
 
 theorem indexedTreeBlockGenerationWF :
     indexedTreeGeneration.WF natFinalEnv indexedTreeBlockEnv := by
@@ -3120,12 +3115,11 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeFinalEnv_ordered' depe
 #guard_msgs in
 #print axioms indexedTreeFinalEnv_ordered
 
-/- The implementation metadata replay inherits only the already classified
-Verify relation and persistent-map contracts; fixture-local native-decision
+/- The implementation metadata replay is now `sorryAx`-free and inherits only
+the already classified persistent-map contracts; fixture-local native-decision
 axioms are deliberately absent. -/
 /--
 info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -3137,7 +3131,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on ax
 
 /--
 info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -3149,7 +3142,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depend
 
 /--
 info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -3161,7 +3153,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on a
 
 /--
 info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTree_verify_aligned' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
diff --git a/Lean4Lean/Verify/Environment/NestedReplay.lean b/Lean4Lean/Verify/Environment/NestedReplay.lean
new file mode 100644
index 00000000..7944dec5
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/NestedReplay.lean
@@ -0,0 +1,3404 @@
+import Lean4Lean.Verify.Environment.SingletonParityReplay
+import Lean4Lean.Verify.Environment.NestedTransformation
+
+/-!
+# Nested environment replay (L4L-09C)
+
+Both ladder fixtures replayed from real stored metadata: the rose tree
+over the completed `List` environment and the nested-indexed family over
+a staged `PVec` boundary.  Each inserts its stored constants through
+`AddInductNestedTrace`, proves the `NestedBlockChecked.WF` package by
+direct concrete typing derivations over the exact phase environments,
+and drives the final map and environment through `TrEnv'.inductNested`,
+with `Ordered` derived and the transitional closures guarded.
+-/
+
+namespace Lean4Lean.NestedReplayFixtures
+
+open Lean
+open Lean4Lean.InductiveReplayFixtures
+open Lean4Lean.NestedRepresentation
+open Lean4Lean.NestedInductiveFixtures
+open VInductDecl
+
+local instance : Inhabited VEnv := ⟨.empty⟩
+local instance : Inhabited VConstVal := ⟨⟨⟨0, .sort .zero⟩, .anonymous⟩⟩
+
+/-! ## The completed List replay as the input boundary -/
+
+theorem listTrEnv07 : TrEnv' .safe listMap07 false listFinalEnv07 :=
+  .induct listAddInduct07 .empty
+
+theorem listFinalOrdered07 : listFinalEnv07.Ordered :=
+  listTrEnv07.wf.ordered
+
+/-! ## The translated rose source and its nested artifact -/
+
+def roseSourceV : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := ``RoseTree
+       uvars := 1
+       type := nestedConstVType09A% RoseTree
+       ctors :=
+         [⟨⟨1, nestedConstVType09A% RoseTree.node⟩, ``RoseTree.node⟩] }]
+
+def roseNestedC? : Option (NestedBlockChecked roseSourceV) :=
+  nestedBlockChecked? [listTarget] roseSourceV
+
+#guard roseNestedC?.isSome
+
+def roseNestedC : NestedBlockChecked roseSourceV :=
+  roseNestedC?.get (by native_decide)
+
+/-! ## Stored metadata and phase maps/environments -/
+
+def roseInfo09 : ConstantInfo := kernelInductInfo% RoseTree
+def roseNodeInfo09 : ConstantInfo := kernelCtorInfo% RoseTree.node
+def roseRecInfo09 : ConstantInfo := kernelRecInfo% RoseTree.rec
+def roseRec1Info09 : ConstantInfo := kernelRecInfo% RoseTree.rec_1
+
+def roseFamilyV : VConstVal := roseSourceV.types[0].toVConstVal
+def roseNodeV : VConstVal := roseSourceV.types[0].ctors[0]
+def roseRecV : VConstVal := roseNestedC.recursors[0]!
+def roseRec1V : VConstVal := roseNestedC.recursors[1]!
+
+#guard roseRecV.name == ``RoseTree.rec
+#guard roseRec1V.name == `Lean4Lean.NestedRepresentation.RoseTree.rec_1
+
+def roseTypeMap09 : ConstMap := listMap07.insert ``RoseTree roseInfo09
+def roseCtorMap09 : ConstMap := roseTypeMap09.insert ``RoseTree.node roseNodeInfo09
+def roseRecMap09 : ConstMap := roseCtorMap09.insert ``RoseTree.rec roseRecInfo09
+def roseMap09 : ConstMap :=
+  roseRecMap09.insert `Lean4Lean.NestedRepresentation.RoseTree.rec_1 roseRec1Info09
+
+def roseTypeEnv09 : VEnv :=
+  (listFinalEnv07.addConst roseFamilyV.name roseFamilyV.toVConstant).get!
+def roseCtorEnv09 : VEnv :=
+  (roseTypeEnv09.addConst roseNodeV.name roseNodeV.toVConstant).get!
+-- the recursor and rule phase environments are defined below, over the
+-- printed literal inventories
+
+
+/-! ## Printed artifact literals
+
+The restored recursor types and rule components, printed from the
+computed artifact and tied back to it below; the concrete typing
+derivations are stated over these literals. -/
+
+/-- Printed image of `roseNestedC.recursors[0]!.type`. -/
+def roseRecTypeL : VExpr :=
+  .forallE
+    (.sort (.succ (.param 1)))
+    (.forallE
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.forallE
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.forallE
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.forallE
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.forallE
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 5))
+                (.app (.bvar 5) (.bvar 0))))))))
+
+def roseRec1TypeL : VExpr :=
+  .forallE
+    (.sort (.succ (.param 1)))
+    (.forallE
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.forallE
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.forallE
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.forallE
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.forallE
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.forallE
+                (.app
+                  (.const `List [.param 1])
+                  (.app
+                    (.const
+                      `Lean4Lean.NestedRepresentation.RoseTree
+                      [.param 1])
+                    (.bvar 5)))
+                (.app (.bvar 4) (.bvar 0))))))))
+
+def roseRule0LhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.lam
+                (.bvar 5)
+                (.lam
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree.rec
+                                  [.param 0, .param 1])
+                                (.bvar 7))
+                              (.bvar 6))
+                            (.bvar 5))
+                          (.bvar 4))
+                        (.bvar 3))
+                      (.bvar 2))
+                    (.app
+                      (.app
+                        (.app
+                          (.const
+                            `Lean4Lean.NestedRepresentation.RoseTree.node
+                            [.param 1])
+                          (.bvar 7))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def roseRule0RhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.lam
+                (.bvar 5)
+                (.lam
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.app
+                      (.app (.bvar 4) (.bvar 1))
+                      (.bvar 0))
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.app
+                                  (.const
+                                    `Lean4Lean.NestedRepresentation.RoseTree.rec_1
+                                    [.param 0, .param 1])
+                                  (.bvar 7))
+                                (.bvar 6))
+                              (.bvar 5))
+                            (.bvar 4))
+                          (.bvar 3))
+                        (.bvar 2))
+                      (.bvar 0))))))))))
+
+def roseRule0TypeL : VExpr :=
+  .forallE
+    (.sort (.succ (.param 1)))
+    (.forallE
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.forallE
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.forallE
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.forallE
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.forallE
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.forallE
+                (.bvar 5)
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.bvar 6)
+                    (.app
+                      (.app
+                        (.app
+                          (.const
+                            `Lean4Lean.NestedRepresentation.RoseTree.node
+                            [.param 1])
+                          (.bvar 7))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def roseRule1LhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.app
+                (.app
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.const
+                              `Lean4Lean.NestedRepresentation.RoseTree.rec_1
+                              [.param 0, .param 1])
+                            (.bvar 5))
+                          (.bvar 4))
+                        (.bvar 3))
+                      (.bvar 2))
+                    (.bvar 1))
+                  (.bvar 0))
+                (.app
+                  (.const `List.nil [.param 1])
+                  (.app
+                    (.const
+                      `Lean4Lean.NestedRepresentation.RoseTree
+                      [.param 1])
+                    (.bvar 5)))))))))
+
+def roseRule1RhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.bvar 1))))))
+
+def roseRule1TypeL : VExpr :=
+  .forallE
+    (.sort (.succ (.param 1)))
+    (.forallE
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.forallE
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.forallE
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.forallE
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.forallE
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.app
+                (.bvar 3)
+                (.app
+                  (.const `List.nil [.param 1])
+                  (.app
+                    (.const
+                      `Lean4Lean.NestedRepresentation.RoseTree
+                      [.param 1])
+                    (.bvar 5)))))))))
+
+def roseRule2LhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.lam
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 5))
+                (.lam
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree.rec_1
+                                  [.param 0, .param 1])
+                                (.bvar 7))
+                              (.bvar 6))
+                            (.bvar 5))
+                          (.bvar 4))
+                        (.bvar 3))
+                      (.bvar 2))
+                    (.app
+                      (.app
+                        (.app
+                          (.const `List.cons [.param 1])
+                          (.app
+                            (.const
+                              `Lean4Lean.NestedRepresentation.RoseTree
+                              [.param 1])
+                            (.bvar 7)))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def roseRule2RhsL : VExpr :=
+  .lam
+    (.sort (.succ (.param 1)))
+    (.lam
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.lam
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.lam
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.lam
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.lam
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.lam
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 5))
+                (.lam
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.app
+                      (.app
+                        (.app (.bvar 2) (.bvar 1))
+                        (.bvar 0))
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.app
+                                  (.app
+                                    (.const
+                                      `Lean4Lean.NestedRepresentation.RoseTree.rec
+                                      [.param 0, .param 1])
+                                    (.bvar 7))
+                                  (.bvar 6))
+                                (.bvar 5))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))
+                        (.bvar 1)))
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.app
+                                  (.const
+                                    `Lean4Lean.NestedRepresentation.RoseTree.rec_1
+                                    [.param 0, .param 1])
+                                  (.bvar 7))
+                                (.bvar 6))
+                              (.bvar 5))
+                            (.bvar 4))
+                          (.bvar 3))
+                        (.bvar 2))
+                      (.bvar 0))))))))))
+
+def roseRule2TypeL : VExpr :=
+  .forallE
+    (.sort (.succ (.param 1)))
+    (.forallE
+      (.forallE
+        (.app
+          (.const
+            `Lean4Lean.NestedRepresentation.RoseTree
+            [.param 1])
+          (.bvar 0))
+        (.sort (.param 0)))
+      (.forallE
+        (.forallE
+          (.app
+            (.const `List [.param 1])
+            (.app
+              (.const
+                `Lean4Lean.NestedRepresentation.RoseTree
+                [.param 1])
+              (.bvar 1)))
+          (.sort (.param 0)))
+        (.forallE
+          (.forallE
+            (.bvar 2)
+            (.forallE
+              (.app
+                (.const `List [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3)))
+              (.forallE
+                (.app (.bvar 2) (.bvar 0))
+                (.app
+                  (.bvar 4)
+                  (.app
+                    (.app
+                      (.app
+                        (.const
+                          `Lean4Lean.NestedRepresentation.RoseTree.node
+                          [.param 1])
+                        (.bvar 5))
+                      (.bvar 2))
+                    (.bvar 1))))))
+          (.forallE
+            (.app
+              (.bvar 1)
+              (.app
+                (.const `List.nil [.param 1])
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 3))))
+            (.forallE
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 4))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 5)))
+                  (.forallE
+                    (.app (.bvar 5) (.bvar 1))
+                    (.forallE
+                      (.app (.bvar 5) (.bvar 1))
+                      (.app
+                        (.bvar 6)
+                        (.app
+                          (.app
+                            (.app
+                              (.const `List.cons [.param 1])
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.RoseTree
+                                  [.param 1])
+                                (.bvar 8)))
+                            (.bvar 3))
+                          (.bvar 2)))))))
+              (.forallE
+                (.app
+                  (.const
+                    `Lean4Lean.NestedRepresentation.RoseTree
+                    [.param 1])
+                  (.bvar 5))
+                (.forallE
+                  (.app
+                    (.const `List [.param 1])
+                    (.app
+                      (.const
+                        `Lean4Lean.NestedRepresentation.RoseTree
+                        [.param 1])
+                      (.bvar 6)))
+                  (.app
+                    (.bvar 5)
+                    (.app
+                      (.app
+                        (.app
+                          (.const `List.cons [.param 1])
+                          (.app
+                            (.const
+                              `Lean4Lean.NestedRepresentation.RoseTree
+                              [.param 1])
+                            (.bvar 7)))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+#guard roseRecV.type == roseRecTypeL
+#guard roseRec1V.type == roseRec1TypeL
+#guard roseNestedC.generatedRules.map (fun df => (df.uvars, df.lhs, df.rhs, df.type)) ==
+  [(2, roseRule0LhsL, roseRule0RhsL, roseRule0TypeL),
+   (2, roseRule1LhsL, roseRule1RhsL, roseRule1TypeL),
+   (2, roseRule2LhsL, roseRule2RhsL, roseRule2TypeL)]
+#guard roseRecV.uvars == 2 && roseRec1V.uvars == 2
+
+
+/-! ## Literal inventories -/
+
+def roseRecVL : VConstVal := ⟨⟨2, roseRecTypeL⟩, ``RoseTree.rec⟩
+def roseRec1VL : VConstVal :=
+  ⟨⟨2, roseRec1TypeL⟩, `Lean4Lean.NestedRepresentation.RoseTree.rec_1⟩
+
+def roseRulesL : List VDefEq :=
+  [⟨2, roseRule0LhsL, roseRule0RhsL, roseRule0TypeL⟩,
+   ⟨2, roseRule1LhsL, roseRule1RhsL, roseRule1TypeL⟩,
+   ⟨2, roseRule2LhsL, roseRule2RhsL, roseRule2TypeL⟩]
+
+theorem roseRecursors_eq : roseNestedC.recursors = [roseRecVL, roseRec1VL] := by
+  native_decide
+
+theorem roseRules_eq : roseNestedC.generatedRules = roseRulesL := by
+  native_decide
+
+def roseRecEnv09 : VEnv :=
+  (roseCtorEnv09.addConst roseRecVL.name roseRecVL.toVConstant).get!
+def roseRec1Env09 : VEnv :=
+  (roseRecEnv09.addConst roseRec1VL.name roseRec1VL.toVConstant).get!
+def roseFinalEnv09 : VEnv :=
+  roseRulesL.foldl VEnv.addDefEq roseRec1Env09
+
+/-! ## Concrete constant well-formedness -/
+
+theorem roseFamilyWF09 : roseFamilyV.toVConstant.WF listFinalEnv07 :=
+  ⟨_, by type_tac⟩
+
+theorem roseTypeEnv09_eq :
+    listFinalEnv07.addConst roseFamilyV.name roseFamilyV.toVConstant =
+      some roseTypeEnv09 := rfl
+
+theorem roseTypeOrdered09 : roseTypeEnv09.Ordered :=
+  .const listFinalOrdered07 roseFamilyWF09 roseTypeEnv09_eq
+
+theorem roseNodeWF09 : roseNodeV.toVConstant.WF roseTypeEnv09 := by
+  have hList : roseTypeEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseTypeEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  exact ⟨_, by type_tac⟩
+
+
+theorem roseCtorEnv09_eq :
+    roseTypeEnv09.addConst roseNodeV.name roseNodeV.toVConstant =
+      some roseCtorEnv09 := rfl
+
+theorem roseCtorOrdered09 : roseCtorEnv09.Ordered :=
+  .const roseTypeOrdered09 roseNodeWF09 roseCtorEnv09_eq
+
+set_option maxRecDepth 4000 in
+theorem roseRecWF09 : (⟨2, roseRecTypeL⟩ : VConstant).WF roseCtorEnv09 := by
+  have hList : roseCtorEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseCtorEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hNode : roseCtorEnv09.constants ``RoseTree.node =
+      some roseNodeV.toVConstant := rfl
+  have hNil : roseCtorEnv09.constants ``List.nil =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl
+  have hCons : roseCtorEnv09.constants ``List.cons =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.forallE (.bvar 0)
+          (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+            (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl
+  exact ⟨_, by type_tac⟩
+
+
+theorem roseRecEnv09_eq :
+    roseCtorEnv09.addConst roseRecVL.name roseRecVL.toVConstant =
+      some roseRecEnv09 := rfl
+
+theorem roseRecOrdered09 : roseRecEnv09.Ordered :=
+  .const roseCtorOrdered09 roseRecWF09 roseRecEnv09_eq
+
+set_option maxRecDepth 4000 in
+theorem roseRec1WF09 : (⟨2, roseRec1TypeL⟩ : VConstant).WF roseRecEnv09 := by
+  have hList : roseRecEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseRecEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hNode : roseRecEnv09.constants ``RoseTree.node =
+      some roseNodeV.toVConstant := rfl
+  have hNil : roseRecEnv09.constants ``List.nil =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl
+  have hCons : roseRecEnv09.constants ``List.cons =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.forallE (.bvar 0)
+          (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+            (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem roseRec1Env09_eq :
+    roseRecEnv09.addConst roseRec1VL.name roseRec1VL.toVConstant =
+      some roseRec1Env09 := rfl
+
+theorem roseRec1Ordered09 : roseRec1Env09.Ordered :=
+  .const roseRecOrdered09 roseRec1WF09 roseRec1Env09_eq
+
+
+/-! ## Rule well-formedness at the rule-phase environment -/
+
+section RuleWF
+
+set_option maxRecDepth 8000
+
+/-- The lookup hypotheses shared by every rule component derivation; the
+environment argument is any `addDefEq` extension of `roseRec1Env09`, whose
+constants agree definitionally. -/
+macro "rose_rule_hyps" e:term : tactic => `(tactic| (
+  have hList : VEnv.constants $e ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : VEnv.constants $e ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hNode : VEnv.constants $e ``RoseTree.node =
+      some roseNodeV.toVConstant := rfl
+  have hNil : VEnv.constants $e ``List.nil =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl
+  have hCons : VEnv.constants $e ``List.cons =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.forallE (.bvar 0)
+          (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+            (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl
+  have hRec : VEnv.constants $e ``RoseTree.rec =
+      some ⟨2, roseRecTypeL⟩ := rfl
+  have hRec1 : VEnv.constants $e
+      `Lean4Lean.NestedRepresentation.RoseTree.rec_1 =
+      some ⟨2, roseRec1TypeL⟩ := rfl))
+
+def roseRuleEnv1 : VEnv := roseRec1Env09.addDefEq roseRulesL[0]
+def roseRuleEnv2 : VEnv := roseRuleEnv1.addDefEq roseRulesL[1]
+
+theorem roseRule0WF09 : roseRulesL[0].WF roseRec1Env09 := by
+  constructor
+  · rose_rule_hyps roseRec1Env09; type_tac
+  · rose_rule_hyps roseRec1Env09; type_tac
+
+theorem roseRule1WF09 : roseRulesL[1].WF roseRuleEnv1 := by
+  constructor
+  · rose_rule_hyps roseRuleEnv1; type_tac
+  · rose_rule_hyps roseRuleEnv1; type_tac
+
+theorem roseRule2WF09 : roseRulesL[2].WF roseRuleEnv2 := by
+  constructor
+  · rose_rule_hyps roseRuleEnv2; type_tac
+  · rose_rule_hyps roseRuleEnv2; type_tac
+
+end RuleWF
+
+
+/-! ## The semantic package -/
+
+theorem roseTypesFold_eq :
+    roseSourceV.blockTypeConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) listFinalEnv07 =
+      some roseTypeEnv09 := rfl
+
+theorem roseCtorsFold_eq :
+    roseSourceV.blockConstructorConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) roseTypeEnv09 =
+      some roseCtorEnv09 := rfl
+
+theorem roseRecsFold_eq :
+    roseNestedC.recursors.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) roseCtorEnv09 =
+      some roseRec1Env09 := by
+  rw [roseRecursors_eq]; rfl
+
+theorem roseNestedWF09 : roseNestedC.WF listFinalEnv07 := by
+  refine ⟨⟨roseFamilyWF09, fun env' h => ?_⟩, fun {typeEnv} h => ?_,
+    fun {typeEnv ctorEnv} hT hC => ?_, fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩
+  · cases Option.some.inj (roseTypeEnv09_eq.symm.trans h)
+    exact trivial
+  · cases Option.some.inj (roseTypesFold_eq.symm.trans h)
+    exact ⟨roseNodeWF09, fun env' h' => by
+      cases Option.some.inj (roseCtorEnv09_eq.symm.trans h')
+      exact trivial⟩
+  · cases Option.some.inj (roseTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (roseCtorsFold_eq.symm.trans hC)
+    rw [roseRecursors_eq]
+    exact ⟨roseRecWF09, fun env' h' => by
+      cases Option.some.inj (roseRecEnv09_eq.symm.trans h')
+      exact ⟨roseRec1WF09, fun env'' h'' => by
+        cases Option.some.inj (roseRec1Env09_eq.symm.trans h'')
+        exact trivial⟩⟩
+  · cases Option.some.inj (roseTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (roseCtorsFold_eq.symm.trans hC)
+    cases Option.some.inj (roseRecsFold_eq.symm.trans hR)
+    rw [roseRules_eq]
+    exact ⟨roseRule0WF09, roseRule1WF09, roseRule2WF09, trivial⟩
+
+
+/-! ## Freshness of the stored insertions -/
+
+theorem listMapWF07 : listMap07.WF :=
+  listCtorMapWF07.insert _ _ listRecFresh07
+
+theorem roseTypeFresh09 : listMap07.find? ``RoseTree = none := by
+  rw [listMap07, listCtorMapWF07.find?_insert, listCtorMap07,
+    listNilMapWF07.find?_insert, listNilMap07,
+    listTypeMapWF07.find?_insert, listTypeMap07,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem roseTypeMapWF09 : roseTypeMap09.WF :=
+  listMapWF07.insert _ _ roseTypeFresh09
+
+theorem roseNodeFresh09 : roseTypeMap09.find? ``RoseTree.node = none := by
+  rw [roseTypeMap09, listMapWF07.find?_insert, listMap07,
+    listCtorMapWF07.find?_insert, listCtorMap07,
+    listNilMapWF07.find?_insert, listNilMap07,
+    listTypeMapWF07.find?_insert, listTypeMap07,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem roseCtorMapWF09 : roseCtorMap09.WF :=
+  roseTypeMapWF09.insert _ _ roseNodeFresh09
+
+theorem roseRecFresh09 : roseCtorMap09.find? ``RoseTree.rec = none := by
+  rw [roseCtorMap09, roseTypeMapWF09.find?_insert, roseTypeMap09,
+    listMapWF07.find?_insert, listMap07,
+    listCtorMapWF07.find?_insert, listCtorMap07,
+    listNilMapWF07.find?_insert, listNilMap07,
+    listTypeMapWF07.find?_insert, listTypeMap07,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem roseRecMapWF09 : roseRecMap09.WF :=
+  roseCtorMapWF09.insert _ _ roseRecFresh09
+
+theorem roseRec1Fresh09 :
+    roseRecMap09.find? `Lean4Lean.NestedRepresentation.RoseTree.rec_1 = none := by
+  rw [roseRecMap09, roseCtorMapWF09.find?_insert, roseCtorMap09,
+    roseTypeMapWF09.find?_insert, roseTypeMap09,
+    listMapWF07.find?_insert, listMap07,
+    listCtorMapWF07.find?_insert, listCtorMap07,
+    listNilMapWF07.find?_insert, listNilMap07,
+    listTypeMapWF07.find?_insert, listTypeMap07,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+/-! ## Stored-metadata translations -/
+
+theorem roseInfoTr09 :
+    TrConstVal .safe listFinalEnv07 roseInfo09 roseFamilyV := by
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr listFinalEnv07 roseInfo09.levelParams []
+      roseInfo09.type roseFamilyV.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS listFinalOrdered07 trivial ⟨_, by type_tac⟩
+
+theorem roseNodeTr09 :
+    TrConstVal .safe roseTypeEnv09 roseNodeInfo09 roseNodeV := by
+  have hList : roseTypeEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseTypeEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr roseTypeEnv09 roseNodeInfo09.levelParams []
+      roseNodeInfo09.type roseNodeV.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS roseTypeOrdered09 trivial ⟨_, by type_tac⟩
+
+theorem roseRecTr09 :
+    TrConstVal .safe roseCtorEnv09 roseRecInfo09 roseRecVL := by
+  have hList : roseCtorEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseCtorEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hNode : roseCtorEnv09.constants ``RoseTree.node =
+      some roseNodeV.toVConstant := rfl
+  have hNil : roseCtorEnv09.constants ``List.nil =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl
+  have hCons : roseCtorEnv09.constants ``List.cons =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.forallE (.bvar 0)
+          (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+            (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr roseCtorEnv09 roseRecInfo09.levelParams []
+      roseRecInfo09.type roseRecVL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := roseRecWF09
+  exact shape.to_trExprS roseCtorOrdered09 trivial ⟨_, hty⟩
+
+theorem roseRec1Tr09 :
+    TrConstVal .safe roseRecEnv09 roseRec1Info09 roseRec1VL := by
+  have hList : roseRecEnv09.constants ``List =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hRose : roseRecEnv09.constants ``RoseTree =
+      some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl
+  have hNode : roseRecEnv09.constants ``RoseTree.node =
+      some roseNodeV.toVConstant := rfl
+  have hNil : roseRecEnv09.constants ``List.nil =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl
+  have hCons : roseRecEnv09.constants ``List.cons =
+      some ⟨1, .forallE (.sort (.succ (.param 0)))
+        (.forallE (.bvar 0)
+          (.forallE (.app (.const `List [.param 0]) (.bvar 1))
+            (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr roseRecEnv09 roseRec1Info09.levelParams []
+      roseRec1Info09.type roseRec1VL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := roseRec1WF09
+  exact shape.to_trExprS roseRecOrdered09 trivial ⟨_, hty⟩
+
+
+/-! ## Recursor K metadata and stored lookups -/
+
+theorem roseKTarget09 : roseNestedC.generation.kTarget = false := by
+  native_decide
+
+theorem roseRecLookup09 :
+    roseMap09.find? ``RoseTree.rec = some roseRecInfo09 := by
+  rw [roseMap09, roseRecMapWF09.find?_insert]
+  simp [roseRecMap09, roseCtorMapWF09.find?_insert]
+
+theorem roseRec1Lookup09 :
+    roseMap09.find? `Lean4Lean.NestedRepresentation.RoseTree.rec_1 =
+      some roseRec1Info09 := by
+  rw [roseMap09, roseRecMapWF09.find?_insert]
+  simp
+
+theorem roseRecK09 :
+    RecursorMapKMatches roseMap09 roseNestedC.recursors
+      roseNestedC.generation.kTarget := by
+  rw [roseRecursors_eq, roseKTarget09]
+  intro recursor hmem
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨roseRecInfo09, roseRecLookup09, by decide⟩
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨roseRec1Info09, roseRec1Lookup09, by decide⟩
+  · cases hmem
+
+/-! ## The nested alignment trace and its `TrEnv'` drive -/
+
+def roseTrace09 :
+    AddInductNestedTrace listMap07 listFinalEnv07 roseSourceV
+      roseMap09 roseFinalEnv09 where
+  nested := roseNestedC
+  nested_wf := roseNestedWF09
+  typeMap := roseTypeMap09
+  typeEnv := roseTypeEnv09
+  ctorMap := roseCtorMap09
+  ctorEnv := roseCtorEnv09
+  recEnv := roseRec1Env09
+  addTypes := .cons
+    { info := roseInfo09
+      kind_eq := trivial
+      tr := roseInfoTr09
+      map_fresh := roseTypeFresh09
+      env_add := roseTypeEnv09_eq
+      map_add := rfl } .nil
+  addCtors := .cons
+    { info := roseNodeInfo09
+      kind_eq := trivial
+      tr := roseNodeTr09
+      map_fresh := roseNodeFresh09
+      env_add := roseCtorEnv09_eq
+      map_add := rfl } .nil
+  addRecs := roseRecursors_eq ▸ .cons
+    { info := roseRecInfo09
+      kind_eq := trivial
+      tr := roseRecTr09
+      map_fresh := roseRecFresh09
+      env_add := roseRecEnv09_eq
+      map_add := rfl } (.cons
+    { info := roseRec1Info09
+      kind_eq := trivial
+      tr := roseRec1Tr09
+      map_fresh := roseRec1Fresh09
+      env_add := roseRec1Env09_eq
+      map_add := rfl } .nil)
+  recK := roseRecK09
+  addRules := ⟨by rw [roseRules_eq]; rfl⟩
+
+theorem roseAddInductNested09 :
+    AddInductNested listMap07 listFinalEnv07 roseSourceV
+      roseMap09 roseFinalEnv09 :=
+  ⟨roseTrace09⟩
+
+/-- The rose-tree nested declaration, replayed from real stored metadata
+over the completed `List` environment through the nested alignment
+constructor. -/
+theorem roseTrEnv09 : TrEnv' .safe roseMap09 false roseFinalEnv09 :=
+  .inductNested roseAddInductNested09 listTrEnv07
+
+theorem roseFinalOrdered09 : roseFinalEnv09.Ordered :=
+  roseTrEnv09.wf.ordered
+
+
+/-! ## Round-trip guards
+
+The stored-metadata surface inserted by the trace is tied to the Theory
+artifact inventory, and the final map/environment pair carries the
+documented closure (persistent-map contracts plus the compiler-trust axioms
+introduced by the `native_decide` observations). -/
+
+#guard roseNestedC.elim.numNested == 1
+#guard roseRecV == roseRecVL && roseRec1V == roseRec1VL
+
+/--
+info: 'Lean4Lean.NestedReplayFixtures.roseTrEnv09' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ PersistentHashMap.findAux_isSome,
+ PersistentHashMap.WF.find?_eq,
+ PersistentHashMap.WF.toList'_insert,
+ roseKTarget09._native.native_decide.ax_1_1,
+ roseNestedC._native.native_decide.ax_1,
+ roseRecursors_eq._native.native_decide.ax_1_1,
+ roseRules_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms roseTrEnv09
+
+/--
+info: 'Lean4Lean.NestedReplayFixtures.roseNestedWF09' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ roseNestedC._native.native_decide.ax_1,
+ roseRecursors_eq._native.native_decide.ax_1_1,
+ roseRules_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms roseNestedWF09
+
+
+/-! # The nested-indexed fixture
+
+`NVTree` nests through the locally declared indexed `PVec`.  The base
+environment stages the `PVec` family and constructors over the completed
+`Nat` replay through `TrEnv'.inductStaging`; the nested trace then inserts
+the stored `NVTree` metadata and drives `TrEnv'.inductNested`. -/
+
+/-! ## Staged `PVec` base -/
+
+def pvecInfo09 : ConstantInfo := kernelInductInfo% PVec
+def pvecNilInfo09 : ConstantInfo := kernelCtorInfo% PVec.nil
+def pvecConsInfo09 : ConstantInfo := kernelCtorInfo% PVec.cons
+
+def pvecFamilyVL : VConstVal :=
+  ⟨⟨0, .forallE (.sort (.succ .zero))
+    (.forallE (.const `Nat []) (.sort (.succ .zero)))⟩, ``PVec⟩
+def pvecNilVL : VConstVal := ⟨⟨0, nestedConstVType09A% PVec.nil⟩, ``PVec.nil⟩
+def pvecConsVL : VConstVal := ⟨⟨0, nestedConstVType09A% PVec.cons⟩, ``PVec.cons⟩
+
+def pvecTypeMap09 : ConstMap := natMap.insert ``PVec pvecInfo09
+def pvecNilMap09 : ConstMap := pvecTypeMap09.insert ``PVec.nil pvecNilInfo09
+def pvecCtorMap09 : ConstMap := pvecNilMap09.insert ``PVec.cons pvecConsInfo09
+
+def pvecTypeEnv09 : VEnv :=
+  (natFinalEnv.addConst pvecFamilyVL.name pvecFamilyVL.toVConstant).get!
+def pvecNilEnv09 : VEnv :=
+  (pvecTypeEnv09.addConst pvecNilVL.name pvecNilVL.toVConstant).get!
+def pvecCtorEnv09 : VEnv :=
+  (pvecNilEnv09.addConst pvecConsVL.name pvecConsVL.toVConstant).get!
+
+theorem pvecTypeFresh09 : natMap.find? ``PVec = none := by
+  rw [natMap, natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem pvecTypeMapWF09 : pvecTypeMap09.WF :=
+  natMap_wf.insert _ _ pvecTypeFresh09
+
+theorem pvecNilFresh09 : pvecTypeMap09.find? ``PVec.nil = none := by
+  rw [pvecTypeMap09, natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem pvecNilMapWF09 : pvecNilMap09.WF :=
+  pvecTypeMapWF09.insert _ _ pvecNilFresh09
+
+theorem pvecConsFresh09 : pvecNilMap09.find? ``PVec.cons = none := by
+  rw [pvecNilMap09, pvecTypeMapWF09.find?_insert, pvecTypeMap09,
+    natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem pvecCtorMapWF09 : pvecCtorMap09.WF :=
+  pvecNilMapWF09.insert _ _ pvecConsFresh09
+
+theorem natFinalOrdered09 : natFinalEnv.Ordered :=
+  (nat_trEnv' (safety := .safe)).wf.ordered
+
+theorem pvecFamilyWF09 : pvecFamilyVL.toVConstant.WF natFinalEnv := by
+  have hNat : natFinalEnv.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem pvecTypeEnv09_eq :
+    natFinalEnv.addConst pvecFamilyVL.name pvecFamilyVL.toVConstant =
+      some pvecTypeEnv09 := rfl
+
+theorem pvecTypeOrdered09 : pvecTypeEnv09.Ordered :=
+  .const natFinalOrdered09 pvecFamilyWF09 pvecTypeEnv09_eq
+
+theorem pvecNilWF09 : pvecNilVL.toVConstant.WF pvecTypeEnv09 := by
+  have hNat : pvecTypeEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hZero : pvecTypeEnv09.constants ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl
+  have hPVec : pvecTypeEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem pvecNilEnv09_eq :
+    pvecTypeEnv09.addConst pvecNilVL.name pvecNilVL.toVConstant =
+      some pvecNilEnv09 := rfl
+
+theorem pvecNilOrdered09 : pvecNilEnv09.Ordered :=
+  .const pvecTypeOrdered09 pvecNilWF09 pvecNilEnv09_eq
+
+theorem pvecConsWF09 : pvecConsVL.toVConstant.WF pvecNilEnv09 := by
+  have hNat : pvecNilEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hSucc : pvecNilEnv09.constants ``Nat.succ =
+      some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl
+  have hPVec : pvecNilEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem pvecConsEnv09_eq :
+    pvecNilEnv09.addConst pvecConsVL.name pvecConsVL.toVConstant =
+      some pvecCtorEnv09 := rfl
+
+theorem pvecCtorOrdered09 : pvecCtorEnv09.Ordered :=
+  .const pvecNilOrdered09 pvecConsWF09 pvecConsEnv09_eq
+
+theorem pvecInfoTr09 : TrConstVal .safe natFinalEnv pvecInfo09 pvecFamilyVL := by
+  have hNat : natFinalEnv.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr natFinalEnv pvecInfo09.levelParams []
+      pvecInfo09.type pvecFamilyVL.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS natFinalOrdered09 trivial ⟨_, by type_tac⟩
+
+theorem pvecNilTr09 : TrConstVal .safe pvecTypeEnv09 pvecNilInfo09 pvecNilVL := by
+  have hNat : pvecTypeEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hZero : pvecTypeEnv09.constants ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl
+  have hPVec : pvecTypeEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr pvecTypeEnv09 pvecNilInfo09.levelParams []
+      pvecNilInfo09.type pvecNilVL.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS pvecTypeOrdered09 trivial ⟨_, by type_tac⟩
+
+theorem pvecConsTr09 : TrConstVal .safe pvecNilEnv09 pvecConsInfo09 pvecConsVL := by
+  have hNat : pvecNilEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hSucc : pvecNilEnv09.constants ``Nat.succ =
+      some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl
+  have hPVec : pvecNilEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr pvecNilEnv09 pvecConsInfo09.levelParams []
+      pvecConsInfo09.type pvecConsVL.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS pvecNilOrdered09 trivial ⟨_, by type_tac⟩
+
+/-- The staged `PVec` boundary: family and constructors present, no
+recursor or rules — exactly the constants the nested `NVTree` artifacts
+reference. -/
+theorem pvecTrEnv09 : TrEnv' .safe pvecCtorMap09 false pvecCtorEnv09 :=
+  .inductStaging (kind := .ctor)
+    { info := pvecConsInfo09
+      kind_eq := trivial
+      tr := pvecConsTr09
+      map_fresh := pvecConsFresh09
+      env_add := pvecConsEnv09_eq
+      map_add := rfl } pvecConsWF09 <|
+  .inductStaging (kind := .ctor)
+    { info := pvecNilInfo09
+      kind_eq := trivial
+      tr := pvecNilTr09
+      map_fresh := pvecNilFresh09
+      env_add := pvecNilEnv09_eq
+      map_add := rfl } pvecNilWF09 <|
+  .inductStaging (kind := .induct)
+    { info := pvecInfo09
+      kind_eq := trivial
+      tr := pvecInfoTr09
+      map_fresh := pvecTypeFresh09
+      env_add := pvecTypeEnv09_eq
+      map_add := rfl } pvecFamilyWF09 nat_trEnv'
+
+
+/-! ## The translated NV source and its nested artifact -/
+
+def nvSourceV : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := ``NVTree
+       uvars := 0
+       type := nestedConstVType09A% NVTree
+       ctors := [⟨⟨0, nestedConstVType09A% NVTree.node⟩, ``NVTree.node⟩] }]
+
+def nvNestedC? : Option (NestedBlockChecked nvSourceV) :=
+  nestedBlockChecked? [NestedTransformation.pvecStoredTarget] nvSourceV
+
+#guard nvNestedC?.isSome
+
+def nvNestedC : NestedBlockChecked nvSourceV :=
+  nvNestedC?.get (by native_decide)
+
+def nvInfo09 : ConstantInfo := kernelInductInfo% NVTree
+def nvNodeInfo09 : ConstantInfo := kernelCtorInfo% NVTree.node
+def nvRecInfo09 : ConstantInfo := kernelRecInfo% NVTree.rec
+def nvRec1Info09 : ConstantInfo := kernelRecInfo% NVTree.rec_1
+
+def nvFamilyV : VConstVal := nvSourceV.types[0].toVConstVal
+def nvNodeV : VConstVal := nvSourceV.types[0].ctors[0]
+
+def nvTypeMap09 : ConstMap := pvecCtorMap09.insert ``NVTree nvInfo09
+def nvCtorMap09 : ConstMap := nvTypeMap09.insert ``NVTree.node nvNodeInfo09
+def nvRecMap09 : ConstMap := nvCtorMap09.insert ``NVTree.rec nvRecInfo09
+def nvMap09 : ConstMap :=
+  nvRecMap09.insert `Lean4Lean.NestedRepresentation.NVTree.rec_1 nvRec1Info09
+
+def nvTypeEnv09 : VEnv :=
+  (pvecCtorEnv09.addConst nvFamilyV.name nvFamilyV.toVConstant).get!
+def nvCtorEnv09 : VEnv :=
+  (nvTypeEnv09.addConst nvNodeV.name nvNodeV.toVConstant).get!
+
+def nvFamilyTypeL : VExpr :=
+  .sort (.succ (.zero))
+
+def nvNodeTypeL : VExpr :=
+  .forallE
+    (.const `Nat [])
+    (.forallE
+      (.app
+        (.app
+          (.const `Lean4Lean.NestedRepresentation.PVec [])
+          (.const `Lean4Lean.NestedRepresentation.NVTree []))
+        (.bvar 0))
+      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+
+def nvRecTypeL : VExpr :=
+  .forallE
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.forallE
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.forallE
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.forallE
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.forallE
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.app (.bvar 5) (.bvar 0)))))))
+
+def nvRec1TypeL : VExpr :=
+  .forallE
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.forallE
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.forallE
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.forallE
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.forallE
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.forallE
+              (.const `Nat [])
+              (.forallE
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.PVec [])
+                    (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                  (.bvar 0))
+                (.app
+                  (.app (.bvar 5) (.bvar 1))
+                  (.bvar 0))))))))
+
+def nvRule0LhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.lam
+              (.const `Nat [])
+              (.lam
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.PVec [])
+                    (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                  (.bvar 0))
+                (.app
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.const
+                              `Lean4Lean.NestedRepresentation.NVTree.rec
+                              [.param 0])
+                            (.bvar 6))
+                          (.bvar 5))
+                        (.bvar 4))
+                      (.bvar 3))
+                    (.bvar 2))
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                      (.bvar 1))
+                    (.bvar 0)))))))))
+
+def nvRule0RhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.lam
+              (.const `Nat [])
+              (.lam
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.PVec [])
+                    (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                  (.bvar 0))
+                (.app
+                  (.app
+                    (.app (.bvar 4) (.bvar 1))
+                    (.bvar 0))
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree.rec_1
+                                  [.param 0])
+                                (.bvar 6))
+                              (.bvar 5))
+                            (.bvar 4))
+                          (.bvar 3))
+                        (.bvar 2))
+                      (.bvar 1))
+                    (.bvar 0)))))))))
+
+def nvRule0TypeL : VExpr :=
+  .forallE
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.forallE
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.forallE
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.forallE
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.forallE
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.forallE
+              (.const `Nat [])
+              (.forallE
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.PVec [])
+                    (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                  (.bvar 0))
+                (.app
+                  (.bvar 6)
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                      (.bvar 1))
+                    (.bvar 0)))))))))
+
+def nvRule1LhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.app
+              (.app
+                (.app
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.const
+                            `Lean4Lean.NestedRepresentation.NVTree.rec_1
+                            [.param 0])
+                          (.bvar 4))
+                        (.bvar 3))
+                      (.bvar 2))
+                    (.bvar 1))
+                  (.bvar 0))
+                (.const `Nat.zero []))
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree [])))))))
+
+def nvRule1RhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.bvar 1)))))
+
+def nvRule1TypeL : VExpr :=
+  .forallE
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.forallE
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.forallE
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.forallE
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.forallE
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.app
+              (.app (.bvar 3) (.const `Nat.zero []))
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree [])))))))
+
+def nvRule2LhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.lam
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.lam
+                (.const `Nat [])
+                (.lam
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree.rec_1
+                                  [.param 0])
+                                (.bvar 7))
+                              (.bvar 6))
+                            (.bvar 5))
+                          (.bvar 4))
+                        (.bvar 3))
+                      (.app
+                        (.const `Nat.succ [])
+                        (.bvar 1)))
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.const `Lean4Lean.NestedRepresentation.PVec.cons [])
+                            (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                          (.bvar 2))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def nvRule2RhsL : VExpr :=
+  .lam
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.lam
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.lam
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.lam
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.lam
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.lam
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.lam
+                (.const `Nat [])
+                (.lam
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.app
+                    (.app
+                      (.app
+                        (.app
+                          (.app (.bvar 3) (.bvar 2))
+                          (.bvar 1))
+                        (.bvar 0))
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.app
+                                  (.const
+                                    `Lean4Lean.NestedRepresentation.NVTree.rec
+                                    [.param 0])
+                                  (.bvar 7))
+                                (.bvar 6))
+                              (.bvar 5))
+                            (.bvar 4))
+                          (.bvar 3))
+                        (.bvar 2)))
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.app
+                                  (.const
+                                    `Lean4Lean.NestedRepresentation.NVTree.rec_1
+                                    [.param 0])
+                                  (.bvar 7))
+                                (.bvar 6))
+                              (.bvar 5))
+                            (.bvar 4))
+                          (.bvar 3))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def nvRule2TypeL : VExpr :=
+  .forallE
+    (.forallE
+      (.const `Lean4Lean.NestedRepresentation.NVTree [])
+      (.sort (.param 0)))
+    (.forallE
+      (.forallE
+        (.const `Nat [])
+        (.forallE
+          (.app
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree []))
+            (.bvar 0))
+          (.sort (.param 0))))
+      (.forallE
+        (.forallE
+          (.const `Nat [])
+          (.forallE
+            (.app
+              (.app
+                (.const `Lean4Lean.NestedRepresentation.PVec [])
+                (.const `Lean4Lean.NestedRepresentation.NVTree []))
+              (.bvar 0))
+            (.forallE
+              (.app
+                (.app (.bvar 2) (.bvar 1))
+                (.bvar 0))
+              (.app
+                (.bvar 4)
+                (.app
+                  (.app
+                    (.const `Lean4Lean.NestedRepresentation.NVTree.node [])
+                    (.bvar 2))
+                  (.bvar 1))))))
+        (.forallE
+          (.app
+            (.app (.bvar 1) (.const `Nat.zero []))
+            (.app
+              (.const `Lean4Lean.NestedRepresentation.PVec.nil [])
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])))
+          (.forallE
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.forallE
+                    (.app (.bvar 6) (.bvar 2))
+                    (.forallE
+                      (.app
+                        (.app (.bvar 6) (.bvar 2))
+                        (.bvar 1))
+                      (.app
+                        (.app
+                          (.bvar 7)
+                          (.app
+                            (.const `Nat.succ [])
+                            (.bvar 3)))
+                        (.app
+                          (.app
+                            (.app
+                              (.app
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.PVec.cons
+                                  [])
+                                (.const
+                                  `Lean4Lean.NestedRepresentation.NVTree
+                                  []))
+                              (.bvar 4))
+                            (.bvar 3))
+                          (.bvar 2))))))))
+            (.forallE
+              (.const `Lean4Lean.NestedRepresentation.NVTree [])
+              (.forallE
+                (.const `Nat [])
+                (.forallE
+                  (.app
+                    (.app
+                      (.const `Lean4Lean.NestedRepresentation.PVec [])
+                      (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                    (.bvar 0))
+                  (.app
+                    (.app
+                      (.bvar 6)
+                      (.app
+                        (.const `Nat.succ [])
+                        (.bvar 1)))
+                    (.app
+                      (.app
+                        (.app
+                          (.app
+                            (.const `Lean4Lean.NestedRepresentation.PVec.cons [])
+                            (.const `Lean4Lean.NestedRepresentation.NVTree []))
+                          (.bvar 2))
+                        (.bvar 1))
+                      (.bvar 0))))))))))
+
+def nvRecVL : VConstVal := ⟨⟨1, nvRecTypeL⟩, ``NVTree.rec⟩
+def nvRec1VL : VConstVal :=
+  ⟨⟨1, nvRec1TypeL⟩, `Lean4Lean.NestedRepresentation.NVTree.rec_1⟩
+
+def nvRulesL : List VDefEq :=
+  [⟨1, nvRule0LhsL, nvRule0RhsL, nvRule0TypeL⟩,
+   ⟨1, nvRule1LhsL, nvRule1RhsL, nvRule1TypeL⟩,
+   ⟨1, nvRule2LhsL, nvRule2RhsL, nvRule2TypeL⟩]
+
+theorem nvRecursors_eq : nvNestedC.recursors = [nvRecVL, nvRec1VL] := by
+  native_decide
+
+theorem nvRules_eq : nvNestedC.generatedRules = nvRulesL := by
+  native_decide
+
+def nvRecEnv09 : VEnv :=
+  (nvCtorEnv09.addConst nvRecVL.name nvRecVL.toVConstant).get!
+def nvRec1Env09 : VEnv :=
+  (nvRecEnv09.addConst nvRec1VL.name nvRec1VL.toVConstant).get!
+def nvFinalEnv09 : VEnv :=
+  nvRulesL.foldl VEnv.addDefEq nvRec1Env09
+
+
+/-! ## NV constant well-formedness and phase chains -/
+
+macro "nv_hyps" e:term : tactic => `(tactic| (
+  have hNat : VEnv.constants $e ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hZero : VEnv.constants $e ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl
+  have hSucc : VEnv.constants $e ``Nat.succ =
+      some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl
+  have hPVec : VEnv.constants $e ``PVec = some pvecFamilyVL.toVConstant := rfl
+  have hPNil : VEnv.constants $e ``PVec.nil = some pvecNilVL.toVConstant := rfl
+  have hPCons : VEnv.constants $e ``PVec.cons = some pvecConsVL.toVConstant := rfl))
+
+theorem nvFamilyWF09 : nvFamilyV.toVConstant.WF pvecCtorEnv09 :=
+  ⟨_, by type_tac⟩
+
+theorem nvTypeEnv09_eq :
+    pvecCtorEnv09.addConst nvFamilyV.name nvFamilyV.toVConstant =
+      some nvTypeEnv09 := rfl
+
+theorem nvTypeOrdered09 : nvTypeEnv09.Ordered :=
+  .const pvecCtorOrdered09 nvFamilyWF09 nvTypeEnv09_eq
+
+theorem nvNodeWF09 : nvNodeV.toVConstant.WF nvTypeEnv09 := by
+  nv_hyps nvTypeEnv09
+  have hNV : nvTypeEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem nvCtorEnv09_eq :
+    nvTypeEnv09.addConst nvNodeV.name nvNodeV.toVConstant =
+      some nvCtorEnv09 := rfl
+
+theorem nvCtorOrdered09 : nvCtorEnv09.Ordered :=
+  .const nvTypeOrdered09 nvNodeWF09 nvCtorEnv09_eq
+
+set_option maxRecDepth 4000 in
+theorem nvRecWF09 : (⟨1, nvRecTypeL⟩ : VConstant).WF nvCtorEnv09 := by
+  nv_hyps nvCtorEnv09
+  have hNV : nvCtorEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hNode : nvCtorEnv09.constants ``NVTree.node =
+      some nvNodeV.toVConstant := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem nvRecEnv09_eq :
+    nvCtorEnv09.addConst nvRecVL.name nvRecVL.toVConstant =
+      some nvRecEnv09 := rfl
+
+theorem nvRecOrdered09 : nvRecEnv09.Ordered :=
+  .const nvCtorOrdered09 nvRecWF09 nvRecEnv09_eq
+
+set_option maxRecDepth 4000 in
+theorem nvRec1WF09 : (⟨1, nvRec1TypeL⟩ : VConstant).WF nvRecEnv09 := by
+  nv_hyps nvRecEnv09
+  have hNV : nvRecEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hNode : nvRecEnv09.constants ``NVTree.node =
+      some nvNodeV.toVConstant := rfl
+  exact ⟨_, by type_tac⟩
+
+theorem nvRec1Env09_eq :
+    nvRecEnv09.addConst nvRec1VL.name nvRec1VL.toVConstant =
+      some nvRec1Env09 := rfl
+
+theorem nvRec1Ordered09 : nvRec1Env09.Ordered :=
+  .const nvRecOrdered09 nvRec1WF09 nvRec1Env09_eq
+
+section NVRuleWF
+
+set_option maxRecDepth 8000
+
+macro "nv_rule_hyps" e:term : tactic => `(tactic| (
+  nv_hyps $e
+  have hNV : VEnv.constants $e ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hNode : VEnv.constants $e ``NVTree.node = some nvNodeV.toVConstant := rfl
+  have hRec : VEnv.constants $e ``NVTree.rec = some ⟨1, nvRecTypeL⟩ := rfl
+  have hRec1 : VEnv.constants $e
+      `Lean4Lean.NestedRepresentation.NVTree.rec_1 = some ⟨1, nvRec1TypeL⟩ := rfl))
+
+def nvRuleEnv1 : VEnv := nvRec1Env09.addDefEq nvRulesL[0]
+def nvRuleEnv2 : VEnv := nvRuleEnv1.addDefEq nvRulesL[1]
+
+theorem nvRule0WF09 : nvRulesL[0].WF nvRec1Env09 := by
+  constructor
+  · nv_rule_hyps nvRec1Env09; type_tac
+  · nv_rule_hyps nvRec1Env09; type_tac
+
+theorem nvRule1WF09 : nvRulesL[1].WF nvRuleEnv1 := by
+  constructor
+  · nv_rule_hyps nvRuleEnv1; type_tac
+  · nv_rule_hyps nvRuleEnv1; type_tac
+
+theorem nvRule2WF09 : nvRulesL[2].WF nvRuleEnv2 := by
+  constructor
+  · nv_rule_hyps nvRuleEnv2; type_tac
+  · nv_rule_hyps nvRuleEnv2; type_tac
+
+end NVRuleWF
+
+
+/-! ## NV semantic package -/
+
+theorem nvTypesFold_eq :
+    nvSourceV.blockTypeConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) pvecCtorEnv09 =
+      some nvTypeEnv09 := rfl
+
+theorem nvCtorsFold_eq :
+    nvSourceV.blockConstructorConstants.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) nvTypeEnv09 =
+      some nvCtorEnv09 := rfl
+
+theorem nvRecsFold_eq :
+    nvNestedC.recursors.foldlM
+      (fun env c => env.addConst c.name c.toVConstant) nvCtorEnv09 =
+      some nvRec1Env09 := by
+  rw [nvRecursors_eq]; rfl
+
+theorem nvNestedWF09 : nvNestedC.WF pvecCtorEnv09 := by
+  refine ⟨⟨nvFamilyWF09, fun env' h => ?_⟩, fun {typeEnv} h => ?_,
+    fun {typeEnv ctorEnv} hT hC => ?_, fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩
+  · cases Option.some.inj (nvTypeEnv09_eq.symm.trans h)
+    exact trivial
+  · cases Option.some.inj (nvTypesFold_eq.symm.trans h)
+    exact ⟨nvNodeWF09, fun env' h' => by
+      cases Option.some.inj (nvCtorEnv09_eq.symm.trans h')
+      exact trivial⟩
+  · cases Option.some.inj (nvTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (nvCtorsFold_eq.symm.trans hC)
+    rw [nvRecursors_eq]
+    exact ⟨nvRecWF09, fun env' h' => by
+      cases Option.some.inj (nvRecEnv09_eq.symm.trans h')
+      exact ⟨nvRec1WF09, fun env'' h'' => by
+        cases Option.some.inj (nvRec1Env09_eq.symm.trans h'')
+        exact trivial⟩⟩
+  · cases Option.some.inj (nvTypesFold_eq.symm.trans hT)
+    cases Option.some.inj (nvCtorsFold_eq.symm.trans hC)
+    cases Option.some.inj (nvRecsFold_eq.symm.trans hR)
+    rw [nvRules_eq]
+    exact ⟨nvRule0WF09, nvRule1WF09, nvRule2WF09, trivial⟩
+
+/-! ## NV freshness and stored-metadata translations -/
+
+theorem nvTypeFresh09 : pvecCtorMap09.find? ``NVTree = none := by
+  rw [pvecCtorMap09, pvecNilMapWF09.find?_insert, pvecNilMap09,
+    pvecTypeMapWF09.find?_insert, pvecTypeMap09,
+    natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem nvTypeMapWF09 : nvTypeMap09.WF :=
+  pvecCtorMapWF09.insert _ _ nvTypeFresh09
+
+theorem nvNodeFresh09 : nvTypeMap09.find? ``NVTree.node = none := by
+  rw [nvTypeMap09, pvecCtorMapWF09.find?_insert, pvecCtorMap09,
+    pvecNilMapWF09.find?_insert, pvecNilMap09,
+    pvecTypeMapWF09.find?_insert, pvecTypeMap09,
+    natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem nvCtorMapWF09 : nvCtorMap09.WF :=
+  nvTypeMapWF09.insert _ _ nvNodeFresh09
+
+theorem nvRecFresh09 : nvCtorMap09.find? ``NVTree.rec = none := by
+  rw [nvCtorMap09, nvTypeMapWF09.find?_insert, nvTypeMap09,
+    pvecCtorMapWF09.find?_insert, pvecCtorMap09,
+    pvecNilMapWF09.find?_insert, pvecNilMap09,
+    pvecTypeMapWF09.find?_insert, pvecTypeMap09,
+    natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem nvRecMapWF09 : nvRecMap09.WF :=
+  nvCtorMapWF09.insert _ _ nvRecFresh09
+
+theorem nvRec1Fresh09 :
+    nvRecMap09.find? `Lean4Lean.NestedRepresentation.NVTree.rec_1 = none := by
+  rw [nvRecMap09, nvCtorMapWF09.find?_insert, nvCtorMap09,
+    nvTypeMapWF09.find?_insert, nvTypeMap09,
+    pvecCtorMapWF09.find?_insert, pvecCtorMap09,
+    pvecNilMapWF09.find?_insert, pvecNilMap09,
+    pvecTypeMapWF09.find?_insert, pvecTypeMap09,
+    natMap_wf.find?_insert, natMap,
+    natCtorMap_wf.find?_insert, natCtorMap,
+    natZeroMap_wf.find?_insert, natZeroMap,
+    natTypeMap_wf.find?_insert, natTypeMap,
+    SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty]
+  simp [SMap.find?]
+
+theorem nvInfoTr09 : TrConstVal .safe pvecCtorEnv09 nvInfo09 nvFamilyV := by
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr pvecCtorEnv09 nvInfo09.levelParams []
+      nvInfo09.type nvFamilyV.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS pvecCtorOrdered09 trivial ⟨_, by type_tac⟩
+
+theorem nvNodeTr09 : TrConstVal .safe nvTypeEnv09 nvNodeInfo09 nvNodeV := by
+  nv_hyps nvTypeEnv09
+  have hNV : nvTypeEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr nvTypeEnv09 nvNodeInfo09.levelParams []
+      nvNodeInfo09.type nvNodeV.toVConstant.type := by
+    tr_type_expr_tac
+  exact shape.to_trExprS nvTypeOrdered09 trivial ⟨_, by type_tac⟩
+
+theorem nvRecTr09 : TrConstVal .safe nvCtorEnv09 nvRecInfo09 nvRecVL := by
+  nv_hyps nvCtorEnv09
+  have hNV : nvCtorEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hNode : nvCtorEnv09.constants ``NVTree.node = some nvNodeV.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr nvCtorEnv09 nvRecInfo09.levelParams []
+      nvRecInfo09.type nvRecVL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := nvRecWF09
+  exact shape.to_trExprS nvCtorOrdered09 trivial ⟨_, hty⟩
+
+theorem nvRec1Tr09 : TrConstVal .safe nvRecEnv09 nvRec1Info09 nvRec1VL := by
+  nv_hyps nvRecEnv09
+  have hNV : nvRecEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl
+  have hNode : nvRecEnv09.constants ``NVTree.node = some nvNodeV.toVConstant := rfl
+  refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩
+  have shape : TrTypeExpr nvRecEnv09 nvRec1Info09.levelParams []
+      nvRec1Info09.type nvRec1VL.toVConstant.type := by
+    tr_type_expr_tac
+  obtain ⟨u, hty⟩ := nvRec1WF09
+  exact shape.to_trExprS nvRecOrdered09 trivial ⟨_, hty⟩
+
+/-! ## NV recursor K metadata, trace, and `TrEnv'` drive -/
+
+theorem nvKTarget09 : nvNestedC.generation.kTarget = false := by
+  native_decide
+
+theorem nvRecLookup09 : nvMap09.find? ``NVTree.rec = some nvRecInfo09 := by
+  rw [nvMap09, nvRecMapWF09.find?_insert]
+  simp [nvRecMap09, nvCtorMapWF09.find?_insert]
+
+theorem nvRec1Lookup09 :
+    nvMap09.find? `Lean4Lean.NestedRepresentation.NVTree.rec_1 =
+      some nvRec1Info09 := by
+  rw [nvMap09, nvRecMapWF09.find?_insert]
+  simp
+
+theorem nvRecK09 :
+    RecursorMapKMatches nvMap09 nvNestedC.recursors
+      nvNestedC.generation.kTarget := by
+  rw [nvRecursors_eq, nvKTarget09]
+  intro recursor hmem
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨nvRecInfo09, nvRecLookup09, by decide⟩
+  rcases List.mem_cons.1 hmem with rfl | hmem
+  · exact ⟨nvRec1Info09, nvRec1Lookup09, by decide⟩
+  · cases hmem
+
+def nvTrace09 :
+    AddInductNestedTrace pvecCtorMap09 pvecCtorEnv09 nvSourceV
+      nvMap09 nvFinalEnv09 where
+  nested := nvNestedC
+  nested_wf := nvNestedWF09
+  typeMap := nvTypeMap09
+  typeEnv := nvTypeEnv09
+  ctorMap := nvCtorMap09
+  ctorEnv := nvCtorEnv09
+  recEnv := nvRec1Env09
+  addTypes := .cons
+    { info := nvInfo09
+      kind_eq := trivial
+      tr := nvInfoTr09
+      map_fresh := nvTypeFresh09
+      env_add := nvTypeEnv09_eq
+      map_add := rfl } .nil
+  addCtors := .cons
+    { info := nvNodeInfo09
+      kind_eq := trivial
+      tr := nvNodeTr09
+      map_fresh := nvNodeFresh09
+      env_add := nvCtorEnv09_eq
+      map_add := rfl } .nil
+  addRecs := nvRecursors_eq ▸ .cons
+    { info := nvRecInfo09
+      kind_eq := trivial
+      tr := nvRecTr09
+      map_fresh := nvRecFresh09
+      env_add := nvRecEnv09_eq
+      map_add := rfl } (.cons
+    { info := nvRec1Info09
+      kind_eq := trivial
+      tr := nvRec1Tr09
+      map_fresh := nvRec1Fresh09
+      env_add := nvRec1Env09_eq
+      map_add := rfl } .nil)
+  recK := nvRecK09
+  addRules := ⟨by rw [nvRules_eq]; rfl⟩
+
+theorem nvAddInductNested09 :
+    AddInductNested pvecCtorMap09 pvecCtorEnv09 nvSourceV
+      nvMap09 nvFinalEnv09 :=
+  ⟨nvTrace09⟩
+
+/-- The nested-indexed declaration, replayed from real stored metadata over
+the staged `PVec` boundary through the nested alignment constructor. -/
+theorem nvTrEnv09 : TrEnv' .safe nvMap09 false nvFinalEnv09 :=
+  .inductNested nvAddInductNested09 pvecTrEnv09
+
+theorem nvFinalOrdered09 : nvFinalEnv09.Ordered :=
+  nvTrEnv09.wf.ordered
+
+#guard nvNestedC.elim.numNested == 1
+
+
+/--
+info: 'Lean4Lean.NestedReplayFixtures.nvTrEnv09' depends on axioms: [propext,
+ Classical.choice,
+ Quot.sound,
+ PersistentHashMap.findAux_isSome,
+ PersistentHashMap.WF.find?_eq,
+ PersistentHashMap.WF.toList'_insert,
+ nvKTarget09._native.native_decide.ax_1_1,
+ nvNestedC._native.native_decide.ax_1,
+ nvRecursors_eq._native.native_decide.ax_1_1,
+ nvRules_eq._native.native_decide.ax_1_1]
+-/
+#guard_msgs in
+#print axioms nvTrEnv09
+
+end Lean4Lean.NestedReplayFixtures
diff --git a/Lean4Lean/Verify/Environment/NestedRepresentation.lean b/Lean4Lean/Verify/Environment/NestedRepresentation.lean
new file mode 100644
index 00000000..63b84c74
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/NestedRepresentation.lean
@@ -0,0 +1,710 @@
+import Lean4Lean.Environment
+import Lean4Lean.Theory.Inductive
+import Lean4Lean.Theory.Meta
+
+/-!
+# L4L-09A: nested-inductive representation audit and decision
+
+This file is the committed design note and the executable metadata probes
+for the nested-inductive representation decision.  Every claim below is
+pinned by a build-failing probe in this file unless it is explicitly marked
+as a forward-looking obligation.  This checkpoint changes no acceptance
+behavior: the probes only observe the implementation and the existing
+Theory analyzers.
+
+## Audit: how the implementation represents nested inductives
+
+`Environment.addInductive` (Inductive/Add.lean) runs three phases:
+
+1. `ElimNestedInductive.run` rewrites the source declaration into a
+   flattened mutual block: every nested occurrence `I Ds is` whose
+   parametric arguments `Ds` mention a block family is replaced by
+   `auxI As is`, where `auxI` is a fresh auxiliary family abstracted over
+   the block parameters `As`, and one auxiliary family is created for each
+   family of `I`'s mutual block, with constructor types instantiated at
+   `Ds` (recursively rewritten).  `aux2nested` records `auxI ↦ I Ds`, open
+   over the block parameters.  Auxiliary names are uniquified against the
+   ambient environment (`mkUniqueName`).
+2. `AddInductive.run` checks and generates the flattened block as an
+   ordinary mutual block, receiving `numNested` (the number of auxiliary
+   families) as opaque metadata.
+3. When `numNested ≠ 0`, a restoration pass rebuilds the final environment
+   from the *pre-block* environment: source families and constructors are
+   re-added with every auxiliary constant replaced by its nested
+   restoration (`Result.restoreNested`), each auxiliary family's recursor
+   is re-added under the name `(mkRecName mainName).appendIndexAfter i`
+   with restored type and rules, and finally every `aux2nested` value
+   `I Ds` is type-checked (the lean4#14577 escape-hatch check, regression
+   tested in `Tests/NestedInductive.lean`).  The auxiliary families,
+   constructors, and recursor names never enter the final environment.
+
+The stored metadata therefore has this shape (probes P1, P2):
+
+- The source `inductInfo` keeps `all` = the source family names only and
+  carries `numNested` = the number of auxiliary families; stored
+  constructor types are in restored form (they mention `I Ds`, e.g.
+  `List (RoseTree α)`).
+- The recursor inventory is one recursor per source family plus one per
+  auxiliary family, all with `all` = source names, and with
+  `numMotives`/`numMinors` counting the *flattened* block's families and
+  minors.  Auxiliary recursors have rules keyed by constructors of the
+  previously declared nested inductive (`List.nil`, `List.cons`, ...) with
+  `nfields` counting the instantiated auxiliary constructor's fields, and
+  every rule RHS references the restored recursor constants mutually.
+- No `_nested.*` constant, and no auxiliary recursor under its original
+  name, survives into the final environment.
+
+## Decision: additive artifact type; `VInductDecl` unchanged
+
+The stored Theory payload for a nested declaration must be the *source*
+`VInductDecl` (restored form), because that is what the implementation
+stores and what Verify alignment must replay.  Storing the flattened block
+is unrepresentable: the final `ConstMap` contains neither the auxiliary
+families nor their constructors (probe P2), and the stored constructor
+types differ from the flattened ones (probe P1).  `VInductDecl` needs no
+new field: `numNested` is implementation metadata recoverable as the
+number of auxiliary specifications, and parity fixtures pin it per row
+exactly as they already pin `numNested == 0` for non-nested rows.
+
+Nested support is an additive checked-block artifact (built in L4L-09B/C),
+coupling:
+
+1. the flattened block as an ordinary `VInductDecl` — probe P4 shows both
+   target fixtures' flattened blocks are already accepted by the existing
+   `identityBlockGeneration?` machinery, so flattening reuses the complete
+   L4L-08 block analyzer and generator unchanged;
+2. one auxiliary specification per auxiliary family, in flattened family
+   order: the auxiliary name, the nested value `I Ds` open over the block
+   parameters (the Theory analog of `aux2nested`), and the restored
+   recursor name — plus executable coherence checks tying the flattened
+   block to the source declaration and to the environment's metadata for
+   `I` at `Ds`;
+3. the restoration substitution σ, a structural constant substitution on
+   `VExpr` (probe P5, `restoreV09A`): on an application spine headed by an
+   auxiliary constant, the first `nparams` spine arguments are consumed
+   and replaced by the instantiated value `I Ds`; auxiliary constructor
+   constants are renamed by prefix into `I`'s constructors, applied to the
+   instantiated value's own arguments; auxiliary recursor constants are
+   renamed (checked *before* the constructor-prefix case, exactly like
+   `restoreNested`'s `auxRec` map); levels come from the recorded value,
+   not the auxiliary constant.
+
+σ has one level-world subtlety (probe P5): specification values live in
+declaration level-world, while recursor types and rules live in recursor
+level-world, so σ over generation artifacts splices
+`value.instL (VLevel.params' uvars elimOffset)`.  Constructor types are
+restored with the unshifted value.  With that splice, σ over the flattened
+block's existing `BlockGenerationChecked` artifacts reproduces the stored
+kernel metadata *exactly* — every recursor type and every rule RHS of all
+three probe fixtures — and no auxiliary constant survives the image.
+Probe P2 additionally shows the port's full nested path reproduces Lean's
+stored metadata field-for-field, and that the final metadata is
+independent of auxiliary-name collisions (the uniquified names are erased
+by σ), so Theory may choose canonical auxiliary names as artifact data.
+
+Rejected alternatives:
+
+- *Flattened block as stored payload*: contradicts the stored metadata
+  (P1/P2); Verify alignment would have to invent constants the
+  implementation never stores.
+- *Changing `VInductDecl` fields*: unnecessary — the probes demonstrate
+  the additive artifact expresses real rose-tree, nested-indexed, and
+  constant-universe metadata; a payload change would ripple through every
+  exported Theory API without demonstrated need.
+- *A Prop-only pre-flattening relation without an artifact*: the
+  specifications and σ are data consumed by generation and replay; a
+  relation alone would force Verify to re-synthesize them.  The artifact's
+  executable coherence checks subsume the relation.
+
+## Obligations recorded for L4L-09B/09C (not claimed here)
+
+- 09B: Theory-side flattening and auxiliary-specification validation —
+  positivity through the existing block analyzer on the flattened block;
+  executable instantiation checks of auxiliary family/constructor types
+  against `I`'s metadata at `Ds`; nearest rejection differentials
+  (ill-typed `Ds` — the lean4#14577 class — wrong specification order,
+  non-matching instantiation).
+- 09C: σ as a total Theory function.  The spine rule needs a simultaneous
+  `instantiateRev`-style multi-substitution for `nparams > 1`: iterating
+  single `VExpr.inst` is wrong once parameter arguments mention bvars.
+  Generation, preservation (typing transport along σ: auxiliary constants
+  behave as definitions `auxI := λ As, I Ds`, so staged flattened-block WF
+  transports to restored WF given environment lookup facts for `I`'s
+  families and constructors), insertion order, and replay of real
+  `Inductive.Add.run` output.
+- The kernel's trailing `checkType (I Ds)` becomes a WF premise of the
+  auxiliary specification, never a trusted escape hatch.
+-/
+
+namespace Lean4Lean.NestedRepresentation
+
+open Lean
+
+/-! ## Probe fixtures
+
+`RoseTree` is the universe-polymorphic rose tree through `List`; `NVTree`
+nests through the locally declared indexed family `PVec` (indices spelled
+with `Nat.zero`/`Nat.succ` to keep the probe dependency maps free of
+notation instances); `CURose` nests `List` at a constant universe, so its
+auxiliary constant carries no block level while the restored `List`
+carries level `1` — the level-instantiation case σ must represent. -/
+
+inductive RoseTree (α : Type u) : Type u where
+  | node : α → List (RoseTree α) → RoseTree α
+
+inductive PVec (α : Type) : Nat → Type where
+  | nil : PVec α Nat.zero
+  | cons : α → {n : Nat} → PVec α n → PVec α (Nat.succ n)
+
+inductive NVTree : Type where
+  | node : (n : Nat) → PVec NVTree n → NVTree
+
+inductive CURose : Type 1 where
+  | node : List CURose → CURose
+
+/-! ## Quoted stored metadata
+
+Local pin records keep this file independent of the replay fixture
+inventory; a change in Lean's emitted metadata is a compile failure. -/
+
+structure InductPins where
+  name : Name
+  lparams : List Name
+  numParams : Nat
+  numIndices : Nat
+  all : List Name
+  ctors : List Name
+  numNested : Nat
+  isRec : Bool
+  isReflexive : Bool
+  isUnsafe : Bool
+  deriving ToExpr, BEq
+
+structure CtorPins where
+  name : Name
+  lparams : List Name
+  induct : Name
+  cidx : Nat
+  numParams : Nat
+  numFields : Nat
+  deriving ToExpr, BEq
+
+structure RecPins where
+  name : Name
+  lparams : List Name
+  all : List Name
+  numParams : Nat
+  numIndices : Nat
+  numMotives : Nat
+  numMinors : Nat
+  k : Bool
+  rules : List (Name × Nat)
+  deriving ToExpr, BEq
+
+open Elab Term in
+elab "nestedInductPins09A%" n:ident : term => do
+  let name ← realizeGlobalConstNoOverloadWithInfo n
+  let .inductInfo i ← getConstInfo name | throwError "expected inductive {name}"
+  return toExpr (InductPins.mk i.name i.levelParams i.numParams i.numIndices
+    i.all i.ctors i.numNested i.isRec i.isReflexive i.isUnsafe)
+
+open Elab Term in
+elab "nestedCtorPins09A%" n:ident : term => do
+  let name ← realizeGlobalConstNoOverloadWithInfo n
+  let .ctorInfo i ← getConstInfo name | throwError "expected constructor {name}"
+  return toExpr (CtorPins.mk i.name i.levelParams i.induct i.cidx
+    i.numParams i.numFields)
+
+open Elab Term in
+elab "nestedRecPins09A%" n:ident : term => do
+  let name ← realizeGlobalConstNoOverloadWithInfo n
+  let .recInfo i ← getConstInfo name | throwError "expected recursor {name}"
+  return toExpr (RecPins.mk i.name i.levelParams i.all i.numParams i.numIndices
+    i.numMotives i.numMinors i.k (i.rules.map fun r => (r.ctor, r.nfields)))
+
+-- Quote a stored `ConstantInfo.type` in that record's own universe order.
+open Elab Term in
+elab "nestedConstVType09A%" n:ident : term => do
+  let name ← realizeGlobalConstNoOverloadWithInfo n
+  let info ← getConstInfo name
+  let type ← Lean4Lean.Meta.expandExpr info.type
+  return toExpr (← Lean4Lean.Meta.ofExpr info.levelParams {} type)
+
+/-! ## P1: stored-metadata pins
+
+The source family keeps `all` = source names and counts its auxiliary
+families in `numNested`; constructor types are restored; the recursor
+inventory reveals the flattened block through `numMotives`/`numMinors` and
+through auxiliary recursors whose rules are keyed by the constructors of a
+previously declared inductive. -/
+
+def roseAux : Name := (`_nested ++ ``List).appendIndexAfter 1
+def nvAux : Name := (`_nested ++ ``PVec).appendIndexAfter 1
+
+def roseInductPins : InductPins := nestedInductPins09A% RoseTree
+def roseNodePins : CtorPins := nestedCtorPins09A% RoseTree.node
+def roseRecPins : RecPins := nestedRecPins09A% RoseTree.rec
+def roseRec1Pins : RecPins := nestedRecPins09A% RoseTree.rec_1
+
+#guard roseInductPins.numNested == 1
+#guard roseInductPins.all == [``RoseTree]
+#guard roseInductPins.ctors == [``RoseTree.node]
+#guard roseInductPins.lparams == [`u] && roseInductPins.numParams == 1
+#guard roseInductPins.isRec && !roseInductPins.isReflexive && !roseInductPins.isUnsafe
+#guard roseNodePins ==
+  { name := ``RoseTree.node, lparams := [`u], induct := ``RoseTree, cidx := 0,
+    numParams := 1, numFields := 2 }
+#guard roseRecPins ==
+  { name := ``RoseTree.rec, lparams := [`u_1, `u], all := [``RoseTree], numParams := 1,
+    numIndices := 0, numMotives := 2, numMinors := 3, k := false,
+    rules := [(``RoseTree.node, 2)] }
+#guard roseRec1Pins ==
+  { name := (mkRecName ``RoseTree).appendIndexAfter 1, lparams := [`u_1, `u],
+    all := [``RoseTree], numParams := 1, numIndices := 0, numMotives := 2, numMinors := 3,
+    k := false, rules := [(``List.nil, 0), (``List.cons, 2)] }
+
+/-- The stored constructor type is the restored form: it mentions
+`List (RoseTree α)`, not an auxiliary constant. -/
+def roseNodeStoredType : VExpr := nestedConstVType09A% RoseTree.node
+
+#guard roseNodeStoredType ==
+  .forallE (.sort (.succ (.param 0)))
+    (.forallE (.bvar 0)
+      (.forallE (.app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 1)))
+        (.app (.const ``RoseTree [.param 0]) (.bvar 2))))
+
+def nvInductPins : InductPins := nestedInductPins09A% NVTree
+def nvNodePins : CtorPins := nestedCtorPins09A% NVTree.node
+def nvRecPins : RecPins := nestedRecPins09A% NVTree.rec
+def nvRec1Pins : RecPins := nestedRecPins09A% NVTree.rec_1
+
+#guard nvInductPins.numNested == 1
+#guard nvInductPins.all == [``NVTree] && nvInductPins.ctors == [``NVTree.node]
+#guard nvNodePins ==
+  { name := ``NVTree.node, lparams := [], induct := ``NVTree, cidx := 0,
+    numParams := 0, numFields := 2 }
+#guard nvRecPins ==
+  { name := ``NVTree.rec, lparams := [`u], all := [``NVTree], numParams := 0,
+    numIndices := 0, numMotives := 2, numMinors := 3, k := false,
+    rules := [(``NVTree.node, 2)] }
+-- The auxiliary recursor keeps the auxiliary family's index and its rules
+-- count the instantiated constructor's fields (`PVec.cons` retains its
+-- implicit index field: 3 fields, not 2).
+#guard nvRec1Pins ==
+  { name := (mkRecName ``NVTree).appendIndexAfter 1, lparams := [`u], all := [``NVTree],
+    numParams := 0, numIndices := 1, numMotives := 2, numMinors := 3, k := false,
+    rules := [(``PVec.nil, 0), (``PVec.cons, 3)] }
+
+def nvNodeStoredType : VExpr := nestedConstVType09A% NVTree.node
+
+#guard nvNodeStoredType ==
+  .forallE (.const ``Nat [])
+    (.forallE (.app (.app (.const ``PVec []) (.const ``NVTree [])) (.bvar 0))
+      (.const ``NVTree []))
+
+def cuInductPins : InductPins := nestedInductPins09A% CURose
+def cuRecPins : RecPins := nestedRecPins09A% CURose.rec
+def cuRec1Pins : RecPins := nestedRecPins09A% CURose.rec_1
+
+#guard cuInductPins.numNested == 1 && cuInductPins.all == [``CURose]
+#guard cuRecPins.rules == [(``CURose.node, 1)] && cuRecPins.numMotives == 2
+#guard cuRec1Pins.rules == [(``List.nil, 0), (``List.cons, 2)]
+
+/-- The restored constructor type instantiates `List` at the constant level
+`1` even though the declaration has no level parameters. -/
+def cuNodeStoredType : VExpr := nestedConstVType09A% CURose.node
+
+#guard cuNodeStoredType ==
+  .forallE (.app (.const ``List [.succ .zero]) (.const ``CURose []))
+    (.const ``CURose [])
+
+/-! ## Shared probe plumbing -/
+
+def sourceType09A (env : Environment) (n : Name) : InductiveType := Id.run do
+  let some (.inductInfo info) := env.find? n | panic! "expected inductive"
+  let ctors := info.ctors.map fun c => Id.run do
+    let some (.ctorInfo ci) := env.find? c | panic! "expected constructor"
+    return { name := c, type := ci.type : Constructor }
+  return { name := n, type := info.type, ctors }
+
+def depMap09A (env : Environment) (ns : List Name) : ConstMap :=
+  ns.foldl (fun m n => m.insert n (env.find? n).get!) {}
+
+open ElimNestedInductive in
+/-- Run the port's flattening phase, returning the flattened block and the
+`aux2nested` values abstracted over the block parameters. -/
+def runElim09A (env : Kernel.Environment) (lparams : List Name) (nparams : Nat)
+    (types : List InductiveType) :
+    Except Kernel.Exception (List InductiveType × List (Name × Expr)) := do
+  let res : ElimNestedInductive.Result ← ElimNestedInductive.run 1000 nparams types env
+    |>.run' { lvls := lparams.map .param, newTypes := types.toArray }
+  return (res.types, res.aux2nested.toList.map fun (n, e) => (n, e.abstract res.params))
+
+/-- Field-for-field stored/ported agreement for the constant kinds a nested
+declaration emits. -/
+def sameConst09A (a b : ConstantInfo) : Bool :=
+  a.name == b.name && a.levelParams == b.levelParams && a.type == b.type &&
+    match a, b with
+    | .recInfo ra, .recInfo rb =>
+        ra.all == rb.all && ra.numParams == rb.numParams &&
+          ra.numIndices == rb.numIndices && ra.numMotives == rb.numMotives &&
+          ra.numMinors == rb.numMinors && ra.k == rb.k &&
+          ra.isUnsafe == rb.isUnsafe &&
+          ra.rules.map (fun r => (r.ctor, r.nfields, r.rhs)) ==
+            rb.rules.map (fun r => (r.ctor, r.nfields, r.rhs))
+    | .inductInfo ia, .inductInfo ib =>
+        ia.all == ib.all && ia.numParams == ib.numParams &&
+          ia.numIndices == ib.numIndices && ia.ctors == ib.ctors &&
+          ia.numNested == ib.numNested && ia.isRec == ib.isRec &&
+          ia.isReflexive == ib.isReflexive && ia.isUnsafe == ib.isUnsafe
+    | .ctorInfo ca, .ctorInfo cb =>
+        ca.induct == cb.induct && ca.cidx == cb.cidx &&
+          ca.numParams == cb.numParams && ca.numFields == cb.numFields &&
+          ca.isUnsafe == cb.isUnsafe
+    | _, _ => false
+
+def roseDeps : List Name := [``List, ``List.nil, ``List.cons]
+def nvDeps : List Name :=
+  [``Nat, ``Nat.zero, ``Nat.succ, ``PVec, ``PVec.nil, ``PVec.cons]
+
+def roseRestored : List Name :=
+  [``RoseTree, ``RoseTree.node, mkRecName ``RoseTree,
+    (mkRecName ``RoseTree).appendIndexAfter 1]
+def nvRestored : List Name :=
+  [``NVTree, ``NVTree.node, mkRecName ``NVTree,
+    (mkRecName ``NVTree).appendIndexAfter 1]
+def cuRestored : List Name :=
+  [``CURose, ``CURose.node, mkRecName ``CURose,
+    (mkRecName ``CURose).appendIndexAfter 1]
+
+/-! ## P2: the port's nested path reproduces the stored metadata
+
+`Environment.addInductive`, run on a dependency-only kernel environment,
+re-creates exactly the constants Lean stores — including every restored
+type and rule RHS — and no auxiliary constant.  The final output is
+independent of auxiliary-name collisions: pre-seeding `_nested.List_1`
+only shifts the uniquified internal names, which restoration erases. -/
+
+open Elab in
+run_meta do
+  let env ← getEnv
+  let checkPort (label : String) (main : Name) (lparams : List Name) (nparams : Nat)
+      (deps auxNames restored : List Name) (extra : ConstMap → ConstMap) :
+      MetaM Unit := do
+    let src := sourceType09A env main
+    let kenv := Kernel.Environment.ofConstants (`_l4l09A ++ main) (extra (depMap09A env deps))
+    match Lean4Lean.Environment.addInductive kenv lparams nparams [src] false false with
+    | .error _ => throwError "{label}: port addInductive failed"
+    | .ok env' =>
+      for n in restored do
+        let some stored := env.find? n | throwError "{label}: {n} not stored"
+        let some ported := env'.find? n | throwError "{label}: {n} missing from port output"
+        unless sameConst09A stored ported do
+          throwError "{label}: stored/ported metadata differ at {n}"
+      for n in auxNames do
+        unless (env'.find? n).isNone do
+          throwError "{label}: auxiliary constant {n} leaked into the final environment"
+        unless (env.find? n).isNone do
+          throwError "{label}: auxiliary constant {n} present in the ambient environment"
+  checkPort "rose" ``RoseTree [`u] 1 roseDeps
+    [roseAux, roseAux ++ `nil, roseAux ++ `cons, mkRecName roseAux,
+      (mkRecName ``RoseTree).appendIndexAfter 2] roseRestored id
+  checkPort "nv" ``NVTree [] 0 nvDeps
+    [nvAux, nvAux ++ `nil, nvAux ++ `cons, mkRecName nvAux,
+      (mkRecName ``NVTree).appendIndexAfter 2] nvRestored id
+  checkPort "cu" ``CURose [] 0 roseDeps
+    [roseAux, mkRecName roseAux] cuRestored id
+  -- auxiliary-name-collision independence
+  checkPort "rose-collision" ``RoseTree [`u] 1 roseDeps
+    [(`_nested ++ ``List).appendIndexAfter 2] roseRestored
+    (fun m => m.insert roseAux (env.find? ``Nat).get!)
+
+/-! ## P3: exact flattening pins
+
+The flattened blocks, translated to binder-erased `VExpr` form.  These are
+the descriptors the L4L-09B transformation must produce. -/
+
+def roseFlatFamilies : List (Name × VExpr) :=
+  [(``RoseTree, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))),
+    (roseAux, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))))]
+
+def roseFlatCtors : List (Name × VExpr) :=
+  [(``RoseTree.node,
+    .forallE (.sort (.succ (.param 0)))
+      (.forallE (.bvar 0)
+        (.forallE (.app (.const roseAux [.param 0]) (.bvar 1))
+          (.app (.const ``RoseTree [.param 0]) (.bvar 2))))),
+   (roseAux ++ `nil,
+    .forallE (.sort (.succ (.param 0))) (.app (.const roseAux [.param 0]) (.bvar 0))),
+   (roseAux ++ `cons,
+    .forallE (.sort (.succ (.param 0)))
+      (.forallE (.app (.const ``RoseTree [.param 0]) (.bvar 0))
+        (.forallE (.app (.const roseAux [.param 0]) (.bvar 1))
+          (.app (.const roseAux [.param 0]) (.bvar 2)))))]
+
+/-- `aux2nested` for the rose tree: `List (RoseTree α)`, open over `α`. -/
+def roseAuxValue : VExpr :=
+  .app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 0))
+
+def nvFlatFamilies : List (Name × VExpr) :=
+  [(``NVTree, .sort (.succ .zero)),
+    (nvAux, .forallE (.const ``Nat []) (.sort (.succ .zero)))]
+
+def nvFlatCtors : List (Name × VExpr) :=
+  [(``NVTree.node,
+    .forallE (.const ``Nat [])
+      (.forallE (.app (.const nvAux []) (.bvar 0)) (.const ``NVTree []))),
+   (nvAux ++ `nil, .app (.const nvAux []) (.const ``Nat.zero [])),
+   (nvAux ++ `cons,
+    .forallE (.const ``NVTree [])
+      (.forallE (.const ``Nat [])
+        (.forallE (.app (.const nvAux []) (.bvar 0))
+          (.app (.const nvAux []) (.app (.const ``Nat.succ []) (.bvar 1))))))]
+
+/-- `aux2nested` for `NVTree`: the closed partial application `PVec NVTree`
+(the index argument stays behind on each occurrence). -/
+def nvAuxValue : VExpr := .app (.const ``PVec []) (.const ``NVTree [])
+
+def cuFlatFamilies : List (Name × VExpr) :=
+  [(``CURose, .sort (.succ (.succ .zero))),
+    (roseAux, .sort (.succ (.succ .zero)))]
+
+def cuFlatCtors : List (Name × VExpr) :=
+  [(``CURose.node, .forallE (.const roseAux []) (.const ``CURose [])),
+   (roseAux ++ `nil, .const roseAux []),
+   (roseAux ++ `cons,
+    .forallE (.const ``CURose []) (.forallE (.const roseAux []) (.const roseAux [])))]
+
+/-- `aux2nested` for `CURose`: the block-level-free auxiliary constant
+restores to `List` at the constant level `1`. -/
+def cuAuxValue : VExpr := .app (.const ``List [.succ .zero]) (.const ``CURose [])
+
+open Elab in
+/-- Translate one flattened block and compare it with its pinned shape. -/
+def checkFlat09A (label : String) (main : Name) (lparams : List Name) (nparams : Nat)
+    (deps : List Name) (families ctors : List (Name × VExpr))
+    (auxValues : List (Name × VExpr)) : MetaM (List VInductiveType) := do
+  let env ← getEnv
+  let src := sourceType09A env main
+  let kenv := Kernel.Environment.ofConstants (`_l4l09AFlat ++ main) (depMap09A env deps)
+  let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src]
+    | throwError "{label}: flattening failed"
+  let uvars := lparams.length
+  let mut vtypes : List VInductiveType := []
+  let mut actualFamilies : List (Name × VExpr) := []
+  let mut actualCtors : List (Name × VExpr) := []
+  for t in flatTypes do
+    let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type
+    actualFamilies := actualFamilies ++ [(t.name, vty)]
+    let mut vctors : List VConstVal := []
+    for c in t.ctors do
+      let vc ← Lean4Lean.Meta.ofExpr lparams {} c.type
+      actualCtors := actualCtors ++ [(c.name, vc)]
+      vctors := vctors ++ [{ name := c.name, uvars, type := vc }]
+    vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }]
+  unless actualFamilies == families do
+    throwError "{label}: flattened families differ from the pinned shape"
+  unless actualCtors == ctors do
+    throwError "{label}: flattened constructors differ from the pinned shape"
+  let mut actualValues : List (Name × VExpr) := []
+  for (n, e) in aux do
+    actualValues := actualValues ++ [(n, ← Lean4Lean.Meta.ofExpr lparams {} e)]
+  unless actualValues == auxValues do
+    throwError "{label}: aux2nested values differ from the pinned shape"
+  return vtypes
+
+/-! ## P4: Theory viability, with acceptance behavior unchanged
+
+The flattened blocks are already inside the supported arbitrary-block
+class, while the source declarations remain rejected by every current
+analyzer and by the public transaction. -/
+
+open Elab in
+run_meta do
+  let checkViability (label : String) (main : Name) (lparams : List Name)
+      (nparams : Nat) (deps : List Name) (families ctors : List (Name × VExpr))
+      (auxValues : List (Name × VExpr)) : MetaM Unit := do
+    let vtypes ← checkFlat09A label main lparams nparams deps families ctors auxValues
+    let uvars := lparams.length
+    let flatDecl : VInductDecl := { uvars, nparams, types := vtypes }
+    unless flatDecl.stage3 do
+      throwError "{label}: flattened block rejected by the block analyzer"
+    unless flatDecl.identityBlockGeneration?.isSome do
+      throwError "{label}: flattened block is not generation-ready"
+    let env ← getEnv
+    let src := sourceType09A env main
+    let vsrcTy ← Lean4Lean.Meta.ofExpr lparams {} src.type
+    let mut vctors : List VConstVal := []
+    for c in src.ctors do
+      vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }]
+    let srcTy : VInductiveType := { name := main, uvars, type := vsrcTy, ctors := vctors }
+    let srcDecl : VInductDecl := { uvars, nparams, types := [srcTy] }
+    if srcDecl.stage3 then
+      throwError "{label}: source declaration unexpectedly accepted by stage3"
+    if srcDecl.checked?.isSome then
+      throwError "{label}: source declaration unexpectedly accepted by checked?"
+    if (VEnv.empty.addInduct srcDecl).isSome then
+      throwError "{label}: source declaration unexpectedly accepted by addInduct"
+  checkViability "rose" ``RoseTree [`u] 1 roseDeps
+    roseFlatFamilies roseFlatCtors [(roseAux, roseAuxValue)]
+  checkViability "nv" ``NVTree [] 0 nvDeps
+    nvFlatFamilies nvFlatCtors [(nvAux, nvAuxValue)]
+  checkViability "cu" ``CURose [] 0 roseDeps
+    cuFlatFamilies cuFlatCtors [(roseAux, cuAuxValue)]
+
+/-! ## P5: the restoration substitution σ
+
+`restoreV09A` mirrors `ElimNestedInductive.Result.restoreNested` on
+`VExpr`.  It is probe-local: the L4L-09C artifact path must define the
+total Theory version (with a simultaneous parameter substitution once
+`nparams > 1` is in scope; the probe fixtures have `nparams ≤ 1`, where
+iterated `VExpr.inst` coincides with it). -/
+
+structure AuxSpec09A where
+  aux : Name
+  np : Nat
+  value : VExpr
+  recName : Name
+
+def instParams09A (value : VExpr) : List VExpr → VExpr
+  | [] => value
+  | [a] => value.inst a
+  | _ => panic! "the probe fixtures have nparams ≤ 1"
+
+def findCtorSpec09A (specs : List AuxSpec09A) (c : Name) : Option (AuxSpec09A × Name) :=
+  specs.findSome? fun spec =>
+    if spec.aux.isPrefixOf c && c != spec.aux then
+      some (spec, c.replacePrefix spec.aux .anonymous)
+    else none
+
+/-- σ.  The recursor-rename case is checked before the constructor-prefix
+case, exactly like `restoreNested`'s `auxRec` map: an auxiliary recursor
+name is prefixed by its auxiliary family name and would otherwise be
+mangled by the constructor branch. -/
+partial def restoreV09A (specs : List AuxSpec09A) (recMap : List (Name × Name)) :
+    VExpr → VExpr
+  | .bvar i => .bvar i
+  | .sort l => .sort l
+  | .lam ty body => .lam (restoreV09A specs recMap ty) (restoreV09A specs recMap body)
+  | .forallE ty body =>
+      .forallE (restoreV09A specs recMap ty) (restoreV09A specs recMap body)
+  | e@(.app ..) => restoreSpine (VExpr.appHead e) (e.appArgs [])
+  | e@(.const ..) => restoreSpine e []
+  where
+  restoreSpine (head : VExpr) (args : List VExpr) : VExpr :=
+    let args' := args.map (restoreV09A specs recMap)
+    match head with
+    | .const c ls =>
+      match recMap.find? (·.1 == c) with
+      | some (_, newName) => (VExpr.const newName ls).appN args'
+      | none =>
+      match specs.find? (·.aux == c) with
+      | some spec =>
+          (instParams09A spec.value (args'.take spec.np)).appN (args'.drop spec.np)
+      | none =>
+      match findCtorSpec09A specs c with
+      | some (spec, suffix) =>
+          let value := instParams09A spec.value (args'.take spec.np)
+          match VExpr.appHead value with
+          | .const iname ils =>
+              (VExpr.const (iname ++ suffix) ils).appN
+                (value.appArgs [] ++ args'.drop spec.np)
+          | _ => panic! "auxiliary value head is not a constant"
+      | none => (VExpr.const c ls).appN args'
+    | h => (restoreV09A specs recMap h).appN args'
+
+open Elab in
+/-- σ over the flattened block's existing generation artifacts reproduces
+the stored kernel metadata exactly: recursor names and types, and every
+rule RHS in the globally flattened order, with no auxiliary constant in
+the image.  Constructor types are restored with the declaration-world
+value; recursor artifacts use the value spliced by the elimination
+offset. -/
+def checkRestore09A (label : String) (main : Name) (lparams : List Name)
+    (nparams : Nat) (deps : List Name) : MetaM Unit := do
+  let env ← getEnv
+  let src := sourceType09A env main
+  let kenv := Kernel.Environment.ofConstants (`_l4l09ARestore ++ main) (depMap09A env deps)
+  let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src]
+    | throwError "{label}: flattening failed"
+  let uvars := lparams.length
+  let mut vtypes : List VInductiveType := []
+  for t in flatTypes do
+    let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type
+    let mut vctors : List VConstVal := []
+    for c in t.ctors do
+      vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }]
+    vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }]
+  let flatDecl : VInductDecl := { uvars, nparams, types := vtypes }
+  let some gen := flatDecl.identityBlockGeneration?
+    | throwError "{label}: flattened block is not generation-ready"
+  let elimOffset := gen.recUvars - uvars
+  let mut declSpecs : List AuxSpec09A := []
+  let mut recSpecs : List AuxSpec09A := []
+  let mut recMap : List (Name × Name) := []
+  let mut i := 1
+  for t in flatTypes.drop 1 do
+    let some (_, value) := aux.find? (·.1 == t.name)
+      | throwError "{label}: no aux2nested value for {t.name}"
+    let v ← Lean4Lean.Meta.ofExpr lparams {} value
+    let recName := (mkRecName main).appendIndexAfter i
+    let recValue := v.instL (VLevel.params' uvars elimOffset)
+    declSpecs := declSpecs ++ [{ aux := t.name, np := nparams, value := v, recName }]
+    recSpecs := recSpecs ++ [{ aux := t.name, np := nparams, value := recValue, recName }]
+    recMap := recMap ++ [(mkRecName t.name, recName)]
+    i := i + 1
+  let auxConsts := declSpecs.map (·.aux) ++ recMap.map (·.1) ++
+    (flatTypes.drop 1).flatMap (fun t => t.ctors.map (·.name))
+  -- declaration-world σ: restored source constructors
+  for (t, vt) in flatTypes.zip vtypes do
+    if t.name == main then
+      for c in vt.ctors do
+        let some stored := env.find? c.name | throwError "{label}: {c.name} not stored"
+        let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {}
+          (← Lean4Lean.Meta.expandExpr stored.type)
+        unless restoreV09A declSpecs recMap c.type == storedType do
+          throwError "{label}: σ(flattened {c.name}) differs from the stored type"
+  -- recursor-world σ: recursor types, names, and every rule RHS
+  let expectedNames := [mkRecName main] ++ recSpecs.map (·.recName)
+  for (r, expected) in gen.recursors.zip expectedNames do
+    let restoredName := match recMap.find? (·.1 == r.name) with
+      | some (_, n) => n
+      | none => r.name
+    unless restoredName == expected do
+      throwError "{label}: restored recursor name {restoredName}, expected {expected}"
+    let some (.recInfo stored) := env.find? expected
+      | throwError "{label}: stored recursor {expected} missing"
+    let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {}
+      (← Lean4Lean.Meta.expandExpr stored.type)
+    let restored := restoreV09A recSpecs recMap r.type
+    unless restored == storedType do
+      throwError "{label}: σ(recursor type) differs from stored for {expected}"
+    unless !VExpr.hasAnyConst auxConsts restored do
+      throwError "{label}: auxiliary constant survives σ in the type of {expected}"
+  let mut storedRules : List (Name × Expr) := []
+  for n in expectedNames do
+    let some (.recInfo stored) := env.find? n
+      | throwError "{label}: stored recursor {n} missing"
+    for rule in stored.rules do
+      storedRules := storedRules ++ [(rule.ctor, rule.rhs)]
+  let genRules := gen.generatedRules
+  unless storedRules.length == genRules.length do
+    throwError "{label}: {genRules.length} generated rules, {storedRules.length} stored"
+  let some (.recInfo mainRec) := env.find? (mkRecName main)
+    | throwError "{label}: stored main recursor missing"
+  for (df, (ctor, storedRhs)) in genRules.zip storedRules do
+    let storedRhs ← Lean4Lean.Meta.ofExpr mainRec.levelParams {}
+      (← Lean4Lean.Meta.expandExpr storedRhs)
+    let restoredRhs := restoreV09A recSpecs recMap df.rhs
+    unless restoredRhs == storedRhs do
+      throwError "{label}: σ(rule rhs) differs from stored for {ctor}"
+    unless !VExpr.hasAnyConst auxConsts restoredRhs &&
+        !VExpr.hasAnyConst auxConsts (restoreV09A recSpecs recMap df.lhs) do
+      throwError "{label}: auxiliary constant survives σ in the rule for {ctor}"
+
+run_meta do
+  checkRestore09A "rose" ``RoseTree [`u] 1 roseDeps
+  checkRestore09A "nv" ``NVTree [] 0 nvDeps
+  checkRestore09A "cu" ``CURose [] 0 roseDeps
+
+end Lean4Lean.NestedRepresentation
diff --git a/Lean4Lean/Verify/Environment/NestedTransformation.lean b/Lean4Lean/Verify/Environment/NestedTransformation.lean
new file mode 100644
index 00000000..320fed6f
--- /dev/null
+++ b/Lean4Lean/Verify/Environment/NestedTransformation.lean
@@ -0,0 +1,383 @@
+import Lean4Lean.Verify.Environment.NestedRepresentation
+import Lean4Lean.Theory.NestedInductiveFixtures
+
+/-!
+# Nested flattening differential (L4L-09B)
+
+Ties the Theory transformation `nestedElimination?` to the implementation:
+
+- the hand-written `List` target block in the Theory fixtures is exactly
+  Lean's stored metadata;
+- on the real rose-tree, nested-indexed, and constant-universe fixtures,
+  the Theory flattening reproduces the port's `ElimNestedInductive` output
+  family for family, constructor for constructor, and specification for
+  `aux2nested` binding — including the canonical auxiliary names — and its
+  auxiliary count equals the stored `numNested`;
+- Theory acceptance (`nestedStage3`) agrees with kernel acceptance on the
+  positives and on the nearest rejections: a parametric argument touching
+  a constructor-local binder (rejected by flattening itself, with the
+  kernel's exact error), an off-spine parametric application (rejected by
+  the unchanged block analyzer where the kernel fails constructor
+  checking), an in-block collision with the canonical auxiliary name
+  (rejected by `blockNamesOK` where the kernel's `checkName` rejects the
+  duplicate insertion), and a missing target declaration.
+-/
+
+namespace Lean4Lean.NestedTransformation
+
+open Lean
+open Lean4Lean.NestedRepresentation
+open Lean4Lean.NestedInductiveFixtures
+open VInductDecl
+
+/-! ## The hand-written `List` target is the stored metadata -/
+
+def listNilStoredType : VExpr := nestedConstVType09A% List.nil
+def listConsStoredType : VExpr := nestedConstVType09A% List.cons
+def listStoredType : VExpr := nestedConstVType09A% List
+
+#guard listTarget.families.map (·.name) == [``List]
+#guard listTarget.nparams == 1
+#guard listTarget.families.map (·.type) == [listStoredType]
+#guard listTarget.families.map (·.ctors.map fun c => (c.name, c.uvars, c.type)) ==
+  [[(``List.nil, 1, listNilStoredType), (``List.cons, 1, listConsStoredType)]]
+
+/-! ## Real-metadata target blocks -/
+
+def pvecStoredTarget : NestedTargetBlock where
+  nparams := 1
+  families :=
+    [{ name := ``PVec
+       uvars := 0
+       type := nestedConstVType09A% PVec
+       ctors :=
+         [⟨⟨0, nestedConstVType09A% PVec.nil⟩, ``PVec.nil⟩,
+          ⟨⟨0, nestedConstVType09A% PVec.cons⟩, ``PVec.cons⟩] }]
+
+/-! ## Shared translation plumbing -/
+
+open Elab in
+/-- Translate a list of kernel `InductiveType`s into a `VInductDecl`. -/
+def toVInductDecl09B (lparams : List Name) (nparams : Nat)
+    (types : List InductiveType) : MetaM VInductDecl := do
+  let uvars := lparams.length
+  let mut vtypes : List VInductiveType := []
+  for t in types do
+    let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type
+    let mut vctors : List VConstVal := []
+    for c in t.ctors do
+      vctors := vctors ++ [⟨⟨uvars, ← Lean4Lean.Meta.ofExpr lparams {} c.type⟩, c.name⟩]
+    vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }]
+  return { uvars, nparams, types := vtypes }
+
+open Elab in
+/-- Check that the Theory flattening of one real source declaration equals
+the port's flattening, that its specifications are the translated
+`aux2nested` bindings, and that its auxiliary count is the stored
+`numNested`. -/
+def checkFlattenParity (label : String) (main : Name) (lparams : List Name)
+    (nparams : Nat) (deps : List Name) (targets : List NestedTargetBlock) :
+    MetaM Unit := do
+  let env ← getEnv
+  let src := sourceType09A env main
+  let kenv := Kernel.Environment.ofConstants (`_l4l09B ++ main) (depMap09A env deps)
+  let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src]
+    | throwError "{label}: port flattening failed"
+  let sourceV ← toVInductDecl09B lparams nparams [src]
+  let portFlatV ← toVInductDecl09B lparams nparams flatTypes
+  let some elim := nestedElimination? targets sourceV
+    | throwError "{label}: Theory flattening failed"
+  unless elim.flat == portFlatV do
+    throwError "{label}: Theory flattened block differs from the port's"
+  unless elim.specs.length == aux.length do
+    throwError "{label}: {elim.specs.length} specs vs {aux.length} aux2nested bindings"
+  for spec in elim.specs do
+    let some (_, value) := aux.find? (·.1 == spec.aux)
+      | throwError "{label}: no aux2nested binding for {spec.aux}"
+    let valueV ← Lean4Lean.Meta.ofExpr lparams {} value
+    unless spec.value == valueV do
+      throwError "{label}: spec value for {spec.aux} differs from aux2nested"
+    let .const target ls := VExpr.appHead valueV
+      | throwError "{label}: aux2nested head is not a constant"
+    unless spec.target == target && spec.levels == ls &&
+        spec.values == valueV.appArgs [] do
+      throwError "{label}: spec decomposition differs for {spec.aux}"
+  let some (.inductInfo stored) := env.find? main
+    | throwError "{label}: stored inductive missing"
+  unless elim.numNested == stored.numNested do
+    throwError "{label}: numNested {elim.numNested} vs stored {stored.numNested}"
+  unless nestedStage3 targets sourceV do
+    throwError "{label}: Theory acceptance rejected an accepted declaration"
+
+run_meta do
+  checkFlattenParity "rose" ``RoseTree [`u] 1 roseDeps [listTarget]
+  checkFlattenParity "nv" ``NVTree [] 0 nvDeps [pvecStoredTarget]
+  checkFlattenParity "cu" ``CURose [] 0 roseDeps [listTarget]
+
+/-! ## Rejection differentials
+
+Each negative is written once at the kernel `Expr` level and once as a
+`VInductDecl`; the kernel run and the Theory gate must both reject. -/
+
+def natDeps09B (env : Environment) : ConstMap :=
+  depMap09A env [``Nat, ``Nat.zero, ``Nat.succ, ``List, ``List.nil, ``List.cons]
+
+/-- `inductive Loose0 | node : (n : Nat) → List (Loose0 n) → Loose0` — the
+parametric argument mentions the constructor-local `n`. -/
+def looseDecl : Declaration :=
+  .inductDecl [] 0
+    [{ name := `Loose0
+       type := .sort 1
+       ctors := [{
+         name := `Loose0.node
+         type := .forallE `n (.const ``Nat [])
+           (.forallE `t
+             (mkApp (mkConst ``List [.zero]) (.app (.const `Loose0 []) (.bvar 0)))
+             (.const `Loose0 []) .default) .default }] }]
+    false
+
+def looseSourceV : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `Loose0
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const ``Nat [])
+             (.forallE (.app (.const ``List [.zero])
+                 (.app (.const `Loose0 []) (.bvar 0)))
+               (.const `Loose0 []))⟩, `Loose0.node⟩] }]
+
+/-- `inductive Bad0N | node : Bad0N → List (Bad0N Nat.zero) → Bad0N` — the
+parametric argument applies a block family off the parameter spine. -/
+def badAppDecl : Declaration :=
+  .inductDecl [] 0
+    [{ name := `Bad0N
+       type := .sort 1
+       ctors := [{
+         name := `Bad0N.node
+         type := .forallE `x (.const `Bad0N [])
+           (.forallE `t
+             (mkApp (mkConst ``List [.zero])
+               (.app (.const `Bad0N []) (.const ``Nat.zero [])))
+             (.const `Bad0N []) .default) .default }] }]
+    false
+
+def badAppSourceV : VInductDecl where
+  uvars := 0
+  nparams := 0
+  types :=
+    [{ name := `Bad0N
+       uvars := 0
+       type := .sort (.succ .zero)
+       ctors :=
+         [⟨⟨0, .forallE (.const `Bad0N [])
+             (.forallE (.app (.const ``List [.zero])
+                 (.app (.const `Bad0N []) (.const ``Nat.zero [])))
+               (.const `Bad0N []))⟩, `Bad0N.node⟩] }]
+
+/-- A two-family source whose second family occupies the canonical first
+auxiliary name `_nested.List_1`. -/
+def collisionDecl : Declaration :=
+  let rose := fun a => mkApp (mkConst `Rose0 [.param `u]) a
+  .inductDecl [`u] 1
+    [{ name := `Rose0
+       type := .forallE `α (.sort (.succ (.param `u))) (.sort (.succ (.param `u))) .default
+       ctors := [{
+         name := `Rose0.node
+         type := .forallE `α (.sort (.succ (.param `u)))
+           (.forallE `t (mkApp (mkConst ``List [.param `u]) (rose (.bvar 0)))
+             (rose (.bvar 1)) .default) .default }] },
+     { name := (`_nested ++ ``List).appendIndexAfter 1
+       type := .forallE `α (.sort (.succ (.param `u))) (.sort (.succ (.param `u))) .default
+       ctors := [] }]
+    false
+
+def collisionSourceV : VInductDecl where
+  uvars := 1
+  nparams := 1
+  types :=
+    [{ name := `Rose0
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors :=
+         [⟨⟨1, .forallE (.sort (.succ (.param 0)))
+             (.forallE (.bvar 0)
+               (.forallE (.app (.const ``List [.param 0])
+                   (.app (.const `Rose0 [.param 0]) (.bvar 1)))
+                 (.app (.const `Rose0 [.param 0]) (.bvar 2))))⟩, `Rose0.node⟩] },
+     { name := (`_nested ++ ``List).appendIndexAfter 1
+       uvars := 1
+       type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))
+       ctors := [] }]
+
+open Elab in
+run_meta do
+  let env ← getEnv
+  let deps := natDeps09B env
+  let kenv := Kernel.Environment.ofConstants `_l4l09BNeg deps
+  -- the loose parametric argument rejects in flattening, with the kernel's
+  -- exact diagnostic
+  match Lean4Lean.addDecl kenv looseDecl with
+  | .ok _ => throwError "loose: kernel accepted a local-variable parametric argument"
+  | .error (.other msg) =>
+      unless msg == "invalid nested inductive datatype 'List', \
+          nested inductive datatypes parameters cannot contain local variables." do
+        throwError "loose: unexpected kernel diagnostic {msg}"
+  | .error _ => throwError "loose: unexpected kernel error shape"
+  unless (nestedElimination? [listTarget] looseSourceV).isNone do
+    throwError "loose: Theory flattening accepted"
+  unless !nestedStage3 [listTarget] looseSourceV do
+    throwError "loose: Theory gate accepted"
+  -- the off-spine parametric application flattens but fails checking
+  match Lean4Lean.addDecl kenv badAppDecl with
+  | .ok _ => throwError "badApp: kernel accepted an off-spine parametric application"
+  | .error _ => pure ()
+  unless (nestedElimination? [listTarget] badAppSourceV).isSome do
+    throwError "badApp: Theory flattening should succeed"
+  unless !nestedStage3 [listTarget] badAppSourceV do
+    throwError "badApp: Theory gate accepted"
+  -- the canonical-name collision rejects at insertion (kernel) and at
+  -- `blockNamesOK` (Theory)
+  match Lean4Lean.addDecl kenv collisionDecl with
+  | .ok _ => throwError "collision: kernel accepted a duplicate auxiliary name"
+  | .error _ => pure ()
+  unless (nestedElimination? [listTarget] collisionSourceV).isSome do
+    throwError "collision: Theory flattening should succeed"
+  unless !nestedStage3 [listTarget] collisionSourceV do
+    throwError "collision: Theory gate accepted"
+  -- a missing target declaration rejects on both sides
+  let kenvNoList := Kernel.Environment.ofConstants `_l4l09BNoList
+    (depMap09A env [``Nat, ``Nat.zero, ``Nat.succ])
+  let roseSrc := sourceType09A env ``RoseTree
+  match Lean4Lean.Environment.addInductive kenvNoList [`u] 1 [roseSrc] false false with
+  | .ok _ => throwError "noTarget: kernel accepted without the List declaration"
+  | .error _ => pure ()
+  let roseV ← toVInductDecl09B [`u] 1 [roseSrc]
+  unless !nestedStage3 [] roseV do
+    throwError "noTarget: Theory gate accepted without target metadata"
+
+/-! ## Restoration parity (L4L-09C)
+
+The Theory restoration over the flattened block's generation artifacts
+reproduces Lean's stored metadata exactly: every restored recursor name,
+universe count, and type, and every rule RHS in the globally flattened
+order, on all three real fixtures.  This runs the product σ
+(`NestedBlockChecked.recursors`/`generatedRules`), not the L4L-09A design
+probe. -/
+
+open Elab in
+def checkRestoreParity (label : String) (main : Name) (lparams : List Name)
+    (nparams : Nat) (targets : List NestedTargetBlock) : MetaM Unit := do
+  let env ← getEnv
+  let src := sourceType09A env main
+  let sourceV ← toVInductDecl09B lparams nparams [src]
+  let some nested := nestedBlockChecked? targets sourceV
+    | throwError "{label}: nested acceptance failed"
+  let expectedNames := [mkRecName main] ++
+    nested.elim.specs.mapIdx fun i _ => (mkRecName main).appendIndexAfter (i + 1)
+  unless nested.recursors.length == expectedNames.length do
+    throwError "{label}: {nested.recursors.length} restored recursors, \
+      expected {expectedNames.length}"
+  for (r, expected) in nested.recursors.zip expectedNames do
+    unless r.name == expected do
+      throwError "{label}: restored recursor name {r.name}, expected {expected}"
+    let some (.recInfo stored) := env.find? expected
+      | throwError "{label}: stored recursor {expected} missing"
+    unless r.uvars == stored.levelParams.length do
+      throwError "{label}: recursor universe count differs for {expected}"
+    let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {}
+      (← Lean4Lean.Meta.expandExpr stored.type)
+    unless r.type == storedType do
+      throwError "{label}: restored recursor type differs from stored for {expected}"
+  let mut storedRules : List (Name × Expr) := []
+  for n in expectedNames do
+    let some (.recInfo stored) := env.find? n
+      | throwError "{label}: stored recursor {n} missing"
+    for rule in stored.rules do
+      storedRules := storedRules ++ [(rule.ctor, rule.rhs)]
+  let rules := nested.generatedRules
+  unless rules.length == storedRules.length do
+    throwError "{label}: {rules.length} restored rules, stored {storedRules.length}"
+  let some (.recInfo mainRec) := env.find? (mkRecName main)
+    | throwError "{label}: stored main recursor missing"
+  for (df, (ctor, storedRhs)) in rules.zip storedRules do
+    let storedRhsV ← Lean4Lean.Meta.ofExpr mainRec.levelParams {}
+      (← Lean4Lean.Meta.expandExpr storedRhs)
+    unless df.rhs == storedRhsV do
+      throwError "{label}: restored rule RHS differs from stored for {ctor}"
+
+run_meta do
+  checkRestoreParity "rose" ``RoseTree [`u] 1 [listTarget]
+  checkRestoreParity "nv" ``NVTree [] 0 [pvecStoredTarget]
+  checkRestoreParity "cu" ``CURose [] 0 [listTarget]
+
+/-! ## Real-output round-trip (L4L-09C)
+
+Run the port's complete `Environment.addInductive` on a dependency-only
+kernel environment and compare its entire output — not the ambient
+elaborator metadata — against the Theory nested artifacts: the stored
+payload against the source constants, and every emitted recursor's name,
+universe count, type, rule constructors, rule field counts, and rule RHSs
+against the restored inventory.  Nothing in this comparison is
+hand-authored: the left side is real `Inductive.Add.run`-derived output
+and the right side is computed by `nestedBlockChecked?`. -/
+
+open Elab in
+def checkOutputRoundTrip (label : String) (main : Name) (lparams : List Name)
+    (nparams : Nat) (deps : List Name) (targets : List NestedTargetBlock) :
+    MetaM Unit := do
+  let env ← getEnv
+  let src := sourceType09A env main
+  let kenv := Kernel.Environment.ofConstants (`_l4l09C ++ main) (depMap09A env deps)
+  let .ok kout := Lean4Lean.Environment.addInductive kenv lparams nparams [src] false false
+    | throwError "{label}: port addInductive failed"
+  let sourceV ← toVInductDecl09B lparams nparams [src]
+  let some nested := nestedBlockChecked? targets sourceV
+    | throwError "{label}: nested acceptance failed"
+  -- the stored payload: families and constructors
+  for tyV in sourceV.types do
+    let some (.inductInfo out) := kout.find? tyV.name
+      | throwError "{label}: output family {tyV.name} missing"
+    let outType ← Lean4Lean.Meta.ofExpr out.levelParams {} (← Lean4Lean.Meta.expandExpr out.type)
+    unless out.levelParams.length == tyV.uvars && outType == tyV.type do
+      throwError "{label}: output family metadata differs for {tyV.name}"
+    unless out.numNested == nested.elim.numNested do
+      throwError "{label}: output numNested {out.numNested} vs \
+        artifact {nested.elim.numNested}"
+    for cV in tyV.ctors do
+      let some (.ctorInfo outC) := kout.find? cV.name
+        | throwError "{label}: output constructor {cV.name} missing"
+      let outCType ← Lean4Lean.Meta.ofExpr outC.levelParams {}
+        (← Lean4Lean.Meta.expandExpr outC.type)
+      unless outC.levelParams.length == cV.uvars && outCType == cV.type do
+        throwError "{label}: output constructor metadata differs for {cV.name}"
+  -- the restored recursors and their rules, in inventory order
+  let mut ruleIdx := 0
+  let rules := nested.generatedRules
+  for r in nested.recursors do
+    let some (.recInfo out) := kout.find? r.name
+      | throwError "{label}: output recursor {r.name} missing"
+    let outType ← Lean4Lean.Meta.ofExpr out.levelParams {} (← Lean4Lean.Meta.expandExpr out.type)
+    unless out.levelParams.length == r.uvars && outType == r.type do
+      throwError "{label}: output recursor metadata differs for {r.name}"
+    unless out.k == nested.generation.kTarget do
+      throwError "{label}: output recursor K flag differs for {r.name}"
+    for rule in out.rules do
+      let some df := rules[ruleIdx]?
+        | throwError "{label}: more output rules than restored rules"
+      let outRhs ← Lean4Lean.Meta.ofExpr out.levelParams {}
+        (← Lean4Lean.Meta.expandExpr rule.rhs)
+      unless outRhs == df.rhs do
+        throwError "{label}: output rule RHS differs for {rule.ctor}"
+      ruleIdx := ruleIdx + 1
+  unless ruleIdx == rules.length do
+    throwError "{label}: {rules.length} restored rules, output consumed {ruleIdx}"
+
+run_meta do
+  checkOutputRoundTrip "rose" ``RoseTree [`u] 1 roseDeps [listTarget]
+  checkOutputRoundTrip "nv" ``NVTree [] 0 nvDeps [pvecStoredTarget]
+  checkOutputRoundTrip "cu" ``CURose [] 0 roseDeps [listTarget]
+
+end Lean4Lean.NestedTransformation
diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean
index b5a87ea6..9d6e6db2 100644
--- a/Lean4Lean/Verify/Environment/Normalization.lean
+++ b/Lean4Lean/Verify/Environment/Normalization.lean
@@ -7,190 +7,37 @@ open Kernel
 
 namespace TypeChecker
 
-/-- The primitive constants whose Theory reflections are required by the
-verified checker. `Nat.pred` and `Nat.bitwise` are kernel primitive names too,
-but they have no dedicated fields in `VEnv.HasPrimitives`. -/
-def reflectedPrimitiveNames : List Name := [
-  ``Bool, ``Bool.false, ``Bool.true,
-  ``Nat, ``Nat.zero, ``Nat.succ,
-  ``Nat.add, ``Nat.sub, ``Nat.mul, ``Nat.pow,
-  ``Nat.gcd, ``Nat.mod, ``Nat.div, ``Nat.beq, ``Nat.ble,
-  ``Nat.land, ``Nat.lor, ``Nat.xor,
-  ``Nat.shiftLeft, ``Nat.shiftRight,
-  ``Char.ofNat, ``String.ofList]
-
-/-- A small Theory environment that contains none of Lean's hard-coded
-primitive names satisfies the primitive-reflection contract vacuously. This is
-useful for isolated staged checker contexts. -/
+/-- Compatibility name for the consumer-neutral reflected-primitive list. -/
+@[deprecated Lean4Lean.VEnv.reflectedPrimitiveNames (since := "2026-08-11")]
+abbrev reflectedPrimitiveNames : List Name :=
+  Lean4Lean.VEnv.reflectedPrimitiveNames
+
+/-- Compatibility shim for the consumer-neutral Theory theorem. -/
+@[deprecated Lean4Lean.VEnv.HasPrimitives.of_avoids (since := "2026-08-11")]
 theorem VEnv.HasPrimitives.of_avoids
     {env : VEnv}
     (h : ∀ n ∈ reflectedPrimitiveNames, env.constants n = none) :
-    env.HasPrimitives := by
-  have noContains (n) (hn : n ∈ reflectedPrimitiveNames) :
-      ¬env.contains n := by
-    rintro ⟨ci, hci⟩
-    rw [h n hn] at hci
-    contradiction
-  have noLookup (n) (hn : n ∈ reflectedPrimitiveNames)
-      {ci} (hci : env.constants n = some ci) : False := by
-    rw [h n hn] at hci
-    contradiction
-  exact {
-    bool := fun hc =>
-      (noContains ``Bool (by simp [reflectedPrimitiveNames]) hc).elim
-    boolFalse := fun hci =>
-      (noLookup ``Bool.false (by simp [reflectedPrimitiveNames]) hci).elim
-    boolTrue := fun hci =>
-      (noLookup ``Bool.true (by simp [reflectedPrimitiveNames]) hci).elim
-    nat := fun hc =>
-      (noContains ``Nat (by simp [reflectedPrimitiveNames]) hc).elim
-    natZero := fun hci =>
-      (noLookup ``Nat.zero (by simp [reflectedPrimitiveNames]) hci).elim
-    natSucc := fun hci =>
-      (noLookup ``Nat.succ (by simp [reflectedPrimitiveNames]) hci).elim
-    natAdd := fun hc =>
-      (noContains ``Nat.add (by simp [reflectedPrimitiveNames]) hc).elim
-    natSub := fun hc =>
-      (noContains ``Nat.sub (by simp [reflectedPrimitiveNames]) hc).elim
-    natMul := fun hc =>
-      (noContains ``Nat.mul (by simp [reflectedPrimitiveNames]) hc).elim
-    natPow := fun hc =>
-      (noContains ``Nat.pow (by simp [reflectedPrimitiveNames]) hc).elim
-    natGcd := fun hc =>
-      (noContains ``Nat.gcd (by simp [reflectedPrimitiveNames]) hc).elim
-    natMod := fun hc =>
-      (noContains ``Nat.mod (by simp [reflectedPrimitiveNames]) hc).elim
-    natDiv := fun hc =>
-      (noContains ``Nat.div (by simp [reflectedPrimitiveNames]) hc).elim
-    natBEq := fun hc =>
-      (noContains ``Nat.beq (by simp [reflectedPrimitiveNames]) hc).elim
-    natBLE := fun hc =>
-      (noContains ``Nat.ble (by simp [reflectedPrimitiveNames]) hc).elim
-    natLAnd := fun hc =>
-      (noContains ``Nat.land (by simp [reflectedPrimitiveNames]) hc).elim
-    natLOr := fun hc =>
-      (noContains ``Nat.lor (by simp [reflectedPrimitiveNames]) hc).elim
-    natXor := fun hc =>
-      (noContains ``Nat.xor (by simp [reflectedPrimitiveNames]) hc).elim
-    natShiftLeft := fun hc =>
-      (noContains ``Nat.shiftLeft
-        (by simp [reflectedPrimitiveNames]) hc).elim
-    natShiftRight := fun hc =>
-      (noContains ``Nat.shiftRight
-        (by simp [reflectedPrimitiveNames]) hc).elim
-    charOfNat := fun hci =>
-      (noLookup ``Char.ofNat (by simp [reflectedPrimitiveNames]) hci).elim
-    stringOfList := fun hci =>
-      (noLookup ``String.ofList
-        (by simp [reflectedPrimitiveNames]) hci).elim }
-
-/-- A fresh Theory constant leaves every other lookup unchanged. -/
+    env.HasPrimitives :=
+  Lean4Lean.VEnv.HasPrimitives.of_avoids h
+
+/-- Compatibility shim for the consumer-neutral Theory theorem. -/
+@[deprecated Lean4Lean.VEnv.addConst_other (since := "2026-08-11")]
 theorem VEnv.addConst_other
     {env env' : VEnv} {name other : Name} {ci : VConstant}
     (hadd : env.addConst name ci = some env')
     (hne : name ≠ other) :
-    env'.constants other = env.constants other := by
-  unfold Lean4Lean.VEnv.addConst at hadd
-  split at hadd <;> cases hadd
-  simp [hne]
-
-/-- Inserting a non-primitive constant preserves the verified checker's
-primitive-reflection contract. The computational reflection equations are
-transported monotonically; the primitive constant lookups themselves are
-unchanged. -/
+    env'.constants other = env.constants other :=
+  Lean4Lean.VEnv.addConst_other hadd hne
+
+/-- Compatibility shim for the consumer-neutral Theory theorem. -/
+@[deprecated Lean4Lean.VEnv.HasPrimitives.addConst (since := "2026-08-11")]
 theorem VEnv.HasPrimitives.addConst
     {env env' : VEnv} {name : Name} {ci : VConstant}
     (H : env.HasPrimitives)
     (hname : name ∉ reflectedPrimitiveNames)
     (hadd : env.addConst name ci = some env') :
-    env'.HasPrimitives := by
-  have lookup (other : Name) (hother : other ∈ reflectedPrimitiveNames) :
-      env'.constants other = env.constants other :=
-    VEnv.addConst_other hadd (by
-      intro h
-      apply hname
-      simpa only [h] using hother)
-  have oldContains (other : Name)
-      (hother : other ∈ reflectedPrimitiveNames) :
-      env'.contains other → env.contains other := by
-    rintro ⟨value, hvalue⟩
-    exact ⟨value, by simpa only [lookup other hother] using hvalue⟩
-  have newContains (other : Name) :
-      env.contains other → env'.contains other := by
-    rintro ⟨value, hvalue⟩
-    exact ⟨value, (VEnv.addConst_le hadd).constants hvalue⟩
-  have hle := VEnv.addConst_le hadd
-  exact {
-    bool := fun h => by
-      obtain ⟨hfalse, htrue⟩ := H.bool (oldContains ``Bool
-        (by simp [reflectedPrimitiveNames]) h)
-      exact ⟨newContains _ hfalse, newContains _ htrue⟩
-    boolFalse := fun h => H.boolFalse (by
-      simpa only [lookup ``Bool.false
-        (by simp [reflectedPrimitiveNames])] using h)
-    boolTrue := fun h => H.boolTrue (by
-      simpa only [lookup ``Bool.true
-        (by simp [reflectedPrimitiveNames])] using h)
-    nat := fun h => by
-      obtain ⟨hzero, hsucc⟩ := H.nat (oldContains ``Nat
-        (by simp [reflectedPrimitiveNames]) h)
-      exact ⟨newContains _ hzero, newContains _ hsucc⟩
-    natZero := fun h => H.natZero (by
-      simpa only [lookup ``Nat.zero
-        (by simp [reflectedPrimitiveNames])] using h)
-    natSucc := fun h => H.natSucc (by
-      simpa only [lookup ``Nat.succ
-        (by simp [reflectedPrimitiveNames])] using h)
-    natAdd := fun h a b =>
-      (H.natAdd (oldContains ``Nat.add
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natSub := fun h a b =>
-      (H.natSub (oldContains ``Nat.sub
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natMul := fun h a b =>
-      (H.natMul (oldContains ``Nat.mul
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natPow := fun h a b =>
-      (H.natPow (oldContains ``Nat.pow
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natGcd := fun h a b =>
-      (H.natGcd (oldContains ``Nat.gcd
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natMod := fun h a b =>
-      (H.natMod (oldContains ``Nat.mod
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natDiv := fun h a b =>
-      (H.natDiv (oldContains ``Nat.div
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natBEq := fun h a b =>
-      (H.natBEq (oldContains ``Nat.beq
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natBLE := fun h a b =>
-      (H.natBLE (oldContains ``Nat.ble
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natLAnd := fun h a b =>
-      (H.natLAnd (oldContains ``Nat.land
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natLOr := fun h a b =>
-      (H.natLOr (oldContains ``Nat.lor
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natXor := fun h a b =>
-      (H.natXor (oldContains ``Nat.xor
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natShiftLeft := fun h a b =>
-      (H.natShiftLeft (oldContains ``Nat.shiftLeft
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    natShiftRight := fun h a b =>
-      (H.natShiftRight (oldContains ``Nat.shiftRight
-        (by simp [reflectedPrimitiveNames]) h) a b).mono hle
-    charOfNat := fun h => H.charOfNat (by
-      simpa only [lookup ``Char.ofNat
-        (by simp [reflectedPrimitiveNames])] using h)
-    stringOfList := fun h => by
-      obtain ⟨hconstant, hnil, hcons⟩ := H.stringOfList (by
-        simpa only [lookup ``String.ofList
-          (by simp [reflectedPrimitiveNames])] using h)
-      exact ⟨hconstant, hnil.mono hle, hcons.mono hle⟩ }
+    env'.HasPrimitives :=
+  Lean4Lean.VEnv.HasPrimitives.addConst H hname hadd
 
 /-- A verified implementation local context remains verified when the Theory
 environment grows.  Kernel local declarations and their free-variable names
@@ -662,7 +509,7 @@ def CandidateContextRun.root
   let context := VContext.mk' wf candidateContext.safety
     candidateContext.lparams candidateContext.fuel
   refine ⟨context, ?_, ?_, namePrefix_ne⟩
-  · simp [context, VContext.mk', MLCtx.lctx,
+  · simp [context, VContext.mk', VContext.mk1, MLCtx.lctx,
       AddInductive.Context.toTypeChecker, lctx_eq]
   · exact VState.WF.empty
 
@@ -1374,14 +1221,12 @@ theorem CandidateExprRun.exists_ofCandidate
       annotations.consumed fresh storedDomain' storedDomain_tr
         ⟨u, annotationDef.hasType.2⟩
     have bodyVenv : bodyCandidateRun.context.venv =
-        candidateRun.context.venv := by simp [bodyCandidateRun]
+        candidateRun.context.venv := rfl
     have bodyLparams : bodyCandidateRun.context.lparams =
-        candidateRun.context.lparams := by
-      simp [bodyCandidateRun, AddInductive.Context.pushLocalDecl]
+        candidateRun.context.lparams := rfl
     have bodyVlctx : bodyCandidateRun.context.vlctx =
         (some (context.freshFVarId, annotations.consumed.fvarsList),
-          .vlam storedDomain') :: candidateRun.context.vlctx := by
-      simp [bodyCandidateRun]
+          .vlam storedDomain') :: candidateRun.context.vlctx := rfl
     have bodyDepth :
         (context.pushLocalDecl name binderInfo
           annotations.consumed).fuel.recDepth = whnfFuel + 1 := by
@@ -1481,14 +1326,12 @@ theorem CandidateExprRun.exists_ofIdentity
     let bodyCandidateRun := candidateRun.pushLocalDecl name binderInfo
       annotations.consumed fresh domain' consumed_tr ⟨u, domainType⟩
     have bodyVenv : bodyCandidateRun.context.venv =
-        candidateRun.context.venv := by simp [bodyCandidateRun]
+        candidateRun.context.venv := rfl
     have bodyLparams : bodyCandidateRun.context.lparams =
-        candidateRun.context.lparams := by
-      simp [bodyCandidateRun, AddInductive.Context.pushLocalDecl]
+        candidateRun.context.lparams := rfl
     have bodyVlctx : bodyCandidateRun.context.vlctx =
         (some (context.freshFVarId, annotations.consumed.fvarsList),
-          .vlam domain') :: candidateRun.context.vlctx := by
-      simp [bodyCandidateRun]
+          .vlam domain') :: candidateRun.context.vlctx := rfl
     have bodyDepth :
         (context.pushLocalDecl name binderInfo
           annotations.consumed).fuel.recDepth =
@@ -2039,6 +1882,46 @@ def CandidateExprSemanticRootInput.semanticOfIdentity
     simpa only [input.venv_eq, input.lparams_eq, input.vlctx_eq] using
       recursive
 
+/-- Interpret a staged root at the deterministic translation of its
+checker-selected view.  For a projection-free view the recursive semantic
+run's endpoint is pinned by strict-translation agreement
+(`CandidateExprRun.view_tr_strict` plus `TrExprS.trExprS?_eq`), so the
+retained `view` field is computed by `trExprS?` and the `Nonempty`
+interpretation is transferred onto it; no choice operator selects data.
+Unlike `semanticOfIdentity` this covers non-identity normalizations, at the
+cost of the executable view-uniqueness certificate. -/
+def CandidateExprSemanticRootInput.semanticOfUnique
+    {env : VEnv} {Us : List Name} {source : Expr}
+    {candidate : AddInductive.CandidateExpr source} {source' : VExpr}
+    (input : CandidateExprSemanticRootInput env Us candidate source')
+    (unique : CandidateExprTraceViewIsUnique candidate.trace) :
+    CandidateExprSemanticRootRun env Us candidate source' :=
+  match hview : trExprS? Us [] candidate.trace.view with
+  | some view =>
+    { contextRun := input.contextRun
+      venv_eq := input.venv_eq
+      lparams_eq := input.lparams_eq
+      vlctx_eq := input.vlctx_eq
+      source_tr := input.source_tr
+      whnfFuel := input.whnfFuel
+      whnfDepth := input.whnfDepth
+      view := view
+      recursive := by
+        obtain ⟨w⟩ := input.exists
+        obtain ⟨inferred, run⟩ := w.recursive
+        cases Option.some.inj
+          (((run.view_tr_strict unique).trExprS?_eq unique.view).symm.trans
+            hview)
+        exact ⟨inferred, run⟩ }
+  | none =>
+      absurd
+        (show (trExprS? Us [] candidate.trace.view).isSome by
+          obtain ⟨w⟩ := input.exists
+          obtain ⟨inferred, run⟩ := w.recursive
+          exact TrExprS.trExprS?_isSome
+            ⟨w.view, run.view_tr_strict unique⟩ unique.view)
+        (by simp [hview])
+
 /-- One explicitly verified root stage shared by every candidate expression
 interpreted before or after family insertion.
 
@@ -3585,12 +3468,17 @@ structure CandidateFamilyStagedInput
   typeEnv : VEnv
   addInduct : AddInductConstant .induct familyContext.env.constants env
     raw.toVConstVal constructorContext.env.constants typeEnv
+  /-- The staged family environment has not yet completed a new projection
+  artifact; any already-complete host structure remains backed by a registered
+  Theory view. -/
+  projectionReady : ProjectionReady constructorContext.env typeEnv
+  structureEtaReady : StructureEtaReady constructorContext.env typeEnv
   family_lctx_eq : familyContext.lctx = {}
   constructorContext_eq : constructorContext =
     { familyContext with env := constructorContext.env }
   quotInit_eq : constructorContext.env.quotInit =
     familyContext.env.quotInit
-  name_not_reflected : raw.name ∉ TypeChecker.reflectedPrimitiveNames
+  name_not_reflected : raw.name ∉ VEnv.reflectedPrimitiveNames
   name_not_primitive :
     Environment.primitives.contains raw.name = false
 
@@ -3622,7 +3510,7 @@ def CandidateFamilyStagedInput.postContext
     have H : env.HasPrimitives := by
       simpa only [preFamily.venv_eq] using
         preFamily.contextRun.context.hasPrimitives
-    exact TypeChecker.VEnv.HasPrimitives.addConst H
+    exact VEnv.HasPrimitives.addConst H
       input.name_not_reflected input.addInduct.env_add
   safePrimitives := by
     intro n ci
@@ -3648,6 +3536,8 @@ def CandidateFamilyStagedInput.postContext
       rw [input.constructorContext_eq]]
     rw [input.quotInit_eq]
     exact postTr
+  projectionReady := input.projectionReady
+  structureEtaReady := input.structureEtaReady
   mlctx := .nil
   mlctx_wf := trivial
   lctx_eq := by
@@ -3765,6 +3655,8 @@ theorem CandidateFamilyStagedInput.validationContextRunFromPre
         have postVenv : input.postContext.venv = input.typeEnv := rfl
         simpa only [validationSafety, postEnv, postVenv] using
           input.postContext.trenv
+      projectionReady := input.postContext.projectionReady
+      structureEtaReady := input.postContext.structureEtaReady
       mlctx_wf := by
         simpa only [terminalLparams] using postMLWF }
   have validationContextEq : validationContext.toContext =
@@ -5403,26 +5295,15 @@ def GenerationCandidateSemanticRun.producedPackage
   run.run.producedPackage context nparams numNested isUnsafe produced
 
 /-
-The evidence types mention exact verifier executions, so these semantic
-interpretation roots intentionally inherit the same transitional Verify
+The evidence types mention exact verifier executions, so the semantic
+interpretation roots below intentionally inherit the same transitional Verify
 closure as `WhnfRun.isDefEq`. Exact guards ensure that the generic assembler
-does not silently widen it.
+does not silently widen it. Theory-only helper closures are guarded by
+`Tests.TheoryConsumerSurface` without importing Verify.
 -/
-/--
-info: 'Lean4Lean.TypeChecker.VEnv.HasPrimitives.addConst' depends on axioms: [propext, Classical.choice, Quot.sound]
--/
-#guard_msgs in
-#print axioms TypeChecker.VEnv.HasPrimitives.addConst
-
-/--
-info: 'Lean4Lean.TypeChecker.VEnv.addConst_other' depends on axioms: [propext, Quot.sound]
--/
-#guard_msgs in
-#print axioms TypeChecker.VEnv.addConst_other
 
 /--
 info: 'Lean4Lean.TypeChecker.AddInductConstant.safePrimitives' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -5433,46 +5314,31 @@ info: 'Lean4Lean.TypeChecker.AddInductConstant.safePrimitives' depends on axioms
 #print axioms TypeChecker.AddInductConstant.safePrimitives
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_env' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_env' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateContextRun.context_env
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lctx' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lctx' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateContextRun.context_lctx
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_safety' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_safety' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateContextRun.context_safety
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lparams' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lparams' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateContextRun.context_lparams
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_fuel' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_fuel' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateContextRun.context_fuel
@@ -5501,9 +5367,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.view_isType_of_terminalSort' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5534,9 +5403,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.source_isType_of_termi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5545,7 +5417,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.source_isType_of_termi
 
 /--
 info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -5554,7 +5425,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depend
 
 /--
 info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewIndices' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -5562,7 +5432,7 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewIndices' depends o
 #print axioms TypeChecker.CandidateExprSemanticRootRun.viewIndices
 
 /--
-info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms CandidateFamilyStagedInput
@@ -5591,9 +5461,12 @@ info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput.rawWF' depends on axioms
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5624,9 +5497,12 @@ info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput.postContext' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5657,9 +5533,12 @@ info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput.postContextRun' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5690,9 +5569,12 @@ info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput.postFamily' depends on a
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5724,9 +5606,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootInput.exists' depends on a
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5757,9 +5642,12 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticListInput.exists' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5790,9 +5678,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticInput.exists_ofProduc
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5823,9 +5714,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateSemanticInput.exists' d
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5856,9 +5750,12 @@ info: 'Lean4Lean.VInductDecl.CandidateFamilySemanticGenerationRun.run' depends o
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5889,9 +5786,12 @@ info: 'Lean4Lean.VInductDecl.CandidateSemanticNormalizedCtorListRun.run' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5922,9 +5822,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.run' depends on axio
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5955,9 +5858,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticShapeRun.run' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -5980,7 +5886,6 @@ info: 'Lean4Lean.VInductDecl.normalizationCandidateGenerationShape' depends on a
 
 /--
 info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofCheck' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -5989,7 +5894,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofC
 
 /--
 info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.generationShape' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6031,9 +5935,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.package' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6064,9 +5971,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.producedPackage' dep
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6075,7 +5985,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.producedPackage' dep
 
 /--
 info: 'Lean4Lean.TypeChecker.VState.WF.empty_of_reserves' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -6096,7 +6005,6 @@ info: 'Lean4Lean.TypeChecker.candidateFreshFVarId_reserved' depends on axioms: [
 
 /--
 info: 'Lean4Lean.TypeChecker.CandidateContextRun.root' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -6108,7 +6016,6 @@ info: 'Lean4Lean.TypeChecker.CandidateContextRun.root' depends on axioms: [prope
 
 /--
 info: 'Lean4Lean.TypeChecker.CandidateContextRun.pushLocalDecl' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  Expr.eqv_eq,
@@ -6145,9 +6052,12 @@ info: 'Lean4Lean.TypeChecker.candidateCheckTypeStep_exists_translation' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6155,7 +6065,7 @@ info: 'Lean4Lean.TypeChecker.candidateCheckTypeStep_exists_translation' depends
 #print axioms TypeChecker.candidateCheckTypeStep_exists_translation
 
 /--
-info: 'Lean4Lean.TypeChecker.IsDefEqRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.IsDefEqRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.IsDefEqRun.ofCandidateStep
@@ -6184,9 +6094,12 @@ info: 'Lean4Lean.TypeChecker.IsDefEqRun.isDefEqU' depends on axioms: [propext,
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6201,7 +6114,6 @@ info: 'Lean4Lean.TypeChecker.candidateTypeAnnotation_fvarsIn' does not depend on
 
 /--
 info: 'Lean4Lean.TypeChecker.candidateTypeAnnotation_exists_translation' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6232,9 +6144,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.exists_ofCandidate' depends on axi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6265,9 +6180,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.exists_ofCandidateFVars' depends o
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6275,19 +6193,19 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.exists_ofCandidateFVars' depends o
 #print axioms TypeChecker.CandidateExprRun.exists_ofCandidateFVars
 
 /--
-info: 'Lean4Lean.TypeChecker.WhnfRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.WhnfRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.WhnfRun.ofCandidateStep
 
 /--
-info: 'Lean4Lean.TypeChecker.CheckTypeRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.CheckTypeRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CheckTypeRun.ofCandidateStep
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateNodeRun.ofCandidate' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateNodeRun.ofCandidate' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateNodeRun.ofCandidate
@@ -6316,9 +6234,12 @@ info: 'Lean4Lean.TypeChecker.CandidateNodeRun.exists_ofCandidate' depends on axi
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6349,9 +6270,12 @@ info: 'Lean4Lean.TypeChecker.CandidateNodeRun.evidence' depends on axioms: [prop
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6382,9 +6306,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.evidence' depends on axioms: [prop
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6392,7 +6319,7 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.evidence' depends on axioms: [prop
 #print axioms TypeChecker.CandidateExprRun.evidence
 
 /--
-info: 'Lean4Lean.TypeChecker.CandidateExprRun.source_tr' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.CandidateExprRun.source_tr' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.CandidateExprRun.source_tr
@@ -6421,9 +6348,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.view_tr' depends on axioms: [prope
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6454,9 +6384,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRootRun.evidence' depends on axioms: [
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6487,9 +6420,12 @@ info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.telDefEq' depends on axioms: [prop
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6497,7 +6433,7 @@ info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.telDefEq' depends on axioms: [prop
 #print axioms TypeChecker.TelDefEqEvidence.telDefEq
 
 /--
-info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.ofTelDefEq' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.ofTelDefEq' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TypeChecker.TelDefEqEvidence.ofTelDefEq
@@ -6526,9 +6462,12 @@ info: 'Lean4Lean.TypeChecker.TelResultDefEqEvidence.replacePrefix' depends on ax
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6559,9 +6498,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.spineEvidence' depends on axioms:
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6592,9 +6534,12 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSpineRun.evidenceAt' depends on axioms
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6603,7 +6548,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSpineRun.evidenceAt' depends on axioms
 
 /--
 info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6612,7 +6556,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on
 
 /--
 info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6621,7 +6564,6 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on
 
 /--
 info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.familyViewType_eq' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6629,10 +6571,7 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.familyViewType_eq' depend
 #print axioms NormalizationCandidateRun.familyViewType_eq
 
 /--
-info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.familyView_eq' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.familyView_eq' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms GenerationCandidateRun.familyView_eq
@@ -6661,9 +6600,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.typeEnv_wf' depends on axiom
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6694,9 +6636,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.familyConst_hasType' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6727,9 +6672,12 @@ info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.rightType_ofChecked' dep
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6737,10 +6685,7 @@ info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.rightType_ofChecked' dep
 #print axioms CandidateNormalizedCtorRun.rightType_ofChecked
 
 /--
-info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.viewTel_eq' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.viewTel_eq' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms CandidateNormalizedCtorRun.viewTel_eq
@@ -6769,9 +6714,12 @@ info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.normalizedCtorRun' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6802,9 +6750,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.wf' depends on axioms: [prop
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6813,7 +6764,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.wf' depends on axioms: [prop
 
 /--
 info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.sameHeaders' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6844,9 +6794,12 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.evidence' depends on ax
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6855,7 +6808,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.evidence' depends on ax
 
 /--
 info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.normalization' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -6886,9 +6838,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.normalizationRun' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6919,9 +6874,12 @@ info: 'Lean4Lean.VInductDecl.NormalizedCtorRun.wf' depends on axioms: [propext,
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6952,9 +6910,12 @@ info: 'Lean4Lean.VInductDecl.GenerationRun.wf' depends on axioms: [propext,
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -6962,17 +6923,13 @@ info: 'Lean4Lean.VInductDecl.GenerationRun.wf' depends on axioms: [propext,
 #print axioms GenerationRun.wf
 
 /--
-info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.package' depends on axioms: [propext,
- sorryAx,
- Classical.choice,
- Quot.sound]
+info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.package' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms GenerationCandidateRun.package
 
 /--
 info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.producedPackage' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -7003,9 +6960,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidatePackage.certificate' depends on
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7036,9 +6996,12 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidatePackage.addInductTrace' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7069,9 +7032,12 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateSemanticInput.construct
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7102,9 +7068,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationBlockRun.wf' depends on axioms: [prope
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7135,9 +7104,12 @@ info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListRun.sameHeaders' de
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7168,9 +7140,12 @@ info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListRun.evidence' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7201,9 +7176,12 @@ info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticInput.exists' depends o
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7234,9 +7212,12 @@ info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListInput.exists' depen
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7267,9 +7248,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateBlockSemanticInput.exists' de
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -7300,9 +7284,12 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateBlockSemanticInput.exists_ofP
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
diff --git a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean
index d9b4ce14..d90eb1f8 100644
--- a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean
+++ b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean
@@ -723,12 +723,12 @@ theorem normalizationMatrix_rec_lookup_unique :
     normalizationMatrixFinalEnv_rec_lookup
 
 /-! The semantic generation helpers used above are guarded in
-`Theory.Typing.InductiveLemmas`; these two guards pin the separate transitional
-Verify closure of metadata translation and final environment replay. -/
+`Theory.Typing.InductiveLemmas`; these two guards pin the separate, now
+`sorryAx`-free Verify closure of metadata translation and final environment
+replay. -/
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -737,7 +737,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrix_trEnv'' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean
index 2a5c6c21..88261d5b 100644
--- a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean
+++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean
@@ -22,6 +22,7 @@ structure SingletonReplayArtifact where
   source : VInductDecl
   inputMap : ConstMap
   inputEnv : VEnv
+  inputMapWF : inputMap.WF
   outputMap : ConstMap
   outputEnv : VEnv
   inputOrdered : inputEnv.Ordered
@@ -150,6 +151,7 @@ def natReplay07 : SingletonReplayArtifact where
   source := natDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := natMap
   outputEnv := natFinalEnv
   inputOrdered := .empty
@@ -161,6 +163,7 @@ def eqReplay07 : SingletonReplayArtifact where
   source := eqDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := eqMap
   outputEnv := eqFinalEnv
   inputOrdered := .empty
@@ -172,6 +175,7 @@ def accReplay07 : SingletonReplayArtifact where
   source := accDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := accMap
   outputEnv := accFinalEnv
   inputOrdered := .empty
@@ -183,6 +187,7 @@ def aliasFormerReplay07 : SingletonReplayArtifact where
   source := aliasFormerRawDecl
   inputMap := typeFamilyAliasMap
   inputEnv := typeFamilyAliasEnv
+  inputMapWF := typeFamilyAliasMap_wf
   outputMap := aliasFormerMap
   outputEnv := aliasFormerFinalEnv
   inputOrdered := typeFamilyAliasEnv_ordered
@@ -194,6 +199,7 @@ def aliasRecReplay07 : SingletonReplayArtifact where
   source := aliasRecRawDecl
   inputMap := recAliasMap
   inputEnv := recAliasEnv
+  inputMapWF := recAliasMap_wf
   outputMap := aliasRecMap
   outputEnv := aliasRecFinalEnv
   inputOrdered := recAliasEnv_ordered
@@ -205,17 +211,19 @@ def normalizationMatrixReplay07 : SingletonReplayArtifact where
   source := normalizationMatrixRawDecl
   inputMap := matrixAliasMap
   inputEnv := normalizationMatrixAliasEnv
+  inputMapWF := matrixAliasMap_wf
   outputMap := normalizationMatrixMap
   outputEnv := normalizationMatrixFinalEnv
   inputOrdered := normalizationMatrixAliasEnv_ordered
   transaction := normalizationMatrix_addInduct
   aligned := normalizationMatrix_aligned
 
-noncomputable def annotatedPiReplay07 : SingletonReplayArtifact where
+def annotatedPiReplay07 : SingletonReplayArtifact where
   label := ``AnnotatedPi
   source := annotatedPiRawDecl
   inputMap := _
   inputEnv := outParamEnv
+  inputMapWF := annotatedReplayInputMap_wf
   outputMap := _
   outputEnv := annotatedPiFinalEnv
   inputOrdered := outParamEnv_ordered
@@ -227,6 +235,7 @@ def annotatedParamReplay07 : SingletonReplayArtifact where
   source := annotatedParamRawDecl
   inputMap := _
   inputEnv := outParamEnv
+  inputMapWF := annotatedReplayInputMap_wf
   outputMap := _
   outputEnv := annotatedParamFinalEnv
   inputOrdered := outParamEnv_ordered
@@ -251,15 +260,13 @@ theorem boolDeclWF07 : boolDecl.WF VEnv.empty := by
     · constructor
       · change True
         trivial
-      · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-        rfl
+      · exact .nil
     · have hctor' := List.mem_singleton.1 hctor
       subst ctor
       constructor
       · change True
         trivial
-      · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero)
-        rfl
+      · exact .nil
 
 def boolGenerationWF07 : boolGenerationChecked.WF VEnv.empty := by
   exact (boolChecked.wf_of_decl boolDeclWF07).identityGeneration .empty
@@ -431,6 +438,7 @@ def boolReplay07 : SingletonReplayArtifact where
   source := boolDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := boolMap07
   outputEnv := boolFinalEnv07
   inputOrdered := .empty
@@ -449,7 +457,7 @@ theorem listCheckedWF07 : listChecked.WF VEnv.empty := by
     · constructor
       · change True
         trivial
-      · rfl
+      · exact .nil
     · have hctor' := List.mem_singleton.1 hctor
       subst ctor
       constructor
@@ -467,9 +475,9 @@ theorem listCheckedWF07 : listChecked.WF VEnv.empty := by
         · exact .inl rfl
         constructor
         · intro _
-          rfl
+          exact .nil
         · trivial
-      · rfl
+      · exact .nil
 
 def listGenerationWF07 : listGenerationChecked.WF VEnv.empty := by
   exact listCheckedWF07.identityGeneration .empty
@@ -655,6 +663,7 @@ def listReplay07 : SingletonReplayArtifact where
   source := listDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := listMap07
   outputEnv := listFinalEnv07
   inputOrdered := .empty
@@ -678,7 +687,7 @@ theorem optionDeclWF07 : optionDecl.WF VEnv.empty := by
     · constructor
       · change True
         trivial
-      · rfl
+      · exact .nil
     · have hctor' := List.mem_singleton.1 hctor
       subst ctor
       constructor
@@ -691,7 +700,7 @@ theorem optionDeclWF07 : optionDecl.WF VEnv.empty := by
         · intro recursive
           contradiction
         · trivial
-      · rfl
+      · exact .nil
 
 def optionGenerationWF07 : optionGenerationChecked.WF VEnv.empty := by
   exact (optionChecked.wf_of_decl optionDeclWF07).identityGeneration .empty
@@ -877,6 +886,7 @@ def optionReplay07 : SingletonReplayArtifact where
   source := optionDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := optionMap07
   outputEnv := optionFinalEnv07
   inputOrdered := .empty
@@ -913,7 +923,7 @@ theorem prodCheckedWF07 : prodChecked.WF VEnv.empty := by
       · intro recursive
         contradiction
       · trivial
-    · rfl
+    · exact .nil
 
 def prodGenerationWF07 : prodGenerationChecked.WF VEnv.empty := by
   exact prodCheckedWF07.identityGeneration .empty
@@ -1051,6 +1061,7 @@ def prodReplay07 : SingletonReplayArtifact where
   source := prodDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := prodMap07
   outputEnv := prodFinalEnv07
   inputOrdered := .empty
@@ -1081,7 +1092,7 @@ theorem andCheckedWF07 : andChecked.WF VEnv.empty := by
       · intro recursive
         contradiction
       · trivial
-    · rfl
+    · exact .nil
 
 def andGenerationWF07 : andGenerationChecked.WF VEnv.empty := by
   exact andCheckedWF07.identityGeneration .empty
@@ -1219,6 +1230,7 @@ def andReplay07 : SingletonReplayArtifact where
   source := andDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := andMap07
   outputEnv := andFinalEnv07
   inputOrdered := .empty
@@ -1243,7 +1255,7 @@ theorem orCheckedWF07 : orChecked.WF VEnv.empty := by
         · intro recursive
           contradiction
         · trivial
-      · rfl
+      · exact .nil
     · have hctor' := List.mem_singleton.1 hctor
       subst ctor
       constructor
@@ -1255,7 +1267,7 @@ theorem orCheckedWF07 : orChecked.WF VEnv.empty := by
         · intro recursive
           contradiction
         · trivial
-      · rfl
+      · exact .nil
 
 def orGenerationWF07 : orGenerationChecked.WF VEnv.empty := by
   exact orCheckedWF07.identityGeneration .empty
@@ -1437,6 +1449,7 @@ def orReplay07 : SingletonReplayArtifact where
   source := orDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := orMap07
   outputEnv := orFinalEnv07
   inputOrdered := .empty
@@ -1463,8 +1476,7 @@ theorem heqCheckedWF07 : heqChecked.WF VEnv.empty := by
         (.forallE (.sort (.param 0))
           (.forallE (.bvar 0) (.sort .zero)))
         [.bvar 1, .bvar 0] (.sort .zero)
-      refine ⟨_, _, rfl, (by type_tac), ?_⟩
-      exact ⟨_, _, rfl, (by type_tac), rfl⟩
+      exact .cons (by type_tac) <| .cons (by type_tac) .nil
 
 def heqGenerationWF07 : heqGenerationChecked.WF VEnv.empty := by
   exact heqCheckedWF07.identityGeneration .empty
@@ -1602,6 +1614,7 @@ def heqReplay07 : SingletonReplayArtifact where
   source := heqDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := heqMap07
   outputEnv := heqFinalEnv07
   inputOrdered := .empty
@@ -1889,7 +1902,7 @@ theorem finCheckedWF07 : finChecked.WF finInputEnv07 := by
       · intro recursive
         contradiction
       · trivial
-    · rfl
+    · exact .nil
 
 def finGenerationWF07 : finGenerationChecked.WF finInputEnv07 := by
   exact finCheckedWF07.identityGeneration finInputEnv_ordered07
@@ -2053,6 +2066,7 @@ def finReplay07 : SingletonReplayArtifact where
   source := finDecl
   inputMap := finInputMap07
   inputEnv := finInputEnv07
+  inputMapWF := finInputMapWF07
   outputMap := finMap07
   outputEnv := finFinalEnv07
   inputOrdered := finInputEnv_ordered07
@@ -2258,7 +2272,7 @@ theorem vectorCheckedWF07 : vectorChecked.WF vectorInputEnv07 := by
       · intro recursive
         contradiction
       · trivial
-    · rfl
+    · exact .nil
 
 def vectorGenerationWF07 :
     vectorGenerationChecked.WF vectorInputEnv07 := by
@@ -2430,6 +2444,7 @@ def vectorReplay07 : SingletonReplayArtifact where
   source := vectorDecl
   inputMap := vectorInputMap07
   inputEnv := vectorInputEnv07
+  inputMapWF := vectorInputMapWF07
   outputMap := vectorMap07
   outputEnv := vectorFinalEnv07
   inputOrdered := vectorInputEnv_ordered07
@@ -2570,6 +2585,7 @@ def punitReplay07 : SingletonReplayArtifact where
   source := punitDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := punitMap07
   outputEnv := punitFinalEnv07
   inputOrdered := .empty
@@ -2669,6 +2685,7 @@ def emptyReplay07 : SingletonReplayArtifact where
   source := emptyDecl
   inputMap := {}
   inputEnv := .empty
+  inputMapWF := SMap.WF.empty
   outputMap := emptyMap07
   outputEnv := emptyFinalEnv07
   inputOrdered := .empty
@@ -2686,13 +2703,13 @@ def singletonFixedReplays : List SingletonReplayArtifact :=
 
 /-- The focused non-identity normalization rows use the same public replay
 artifact as the standard-library matrix. -/
-noncomputable def singletonNormalizationReplays :
+def singletonNormalizationReplays :
     List SingletonReplayArtifact :=
   [aliasFormerReplay07, aliasRecReplay07, normalizationMatrixReplay07,
     annotatedPiReplay07, annotatedParamReplay07]
 
 /-- The sole public L4L-07 environment replay inventory. -/
-noncomputable def singletonReplayMatrix : List SingletonReplayArtifact :=
+def singletonReplayMatrix : List SingletonReplayArtifact :=
   singletonFixedReplays ++ singletonNormalizationReplays
 
 example : singletonFixedReplays.map (·.label) =
@@ -2719,7 +2736,6 @@ example : singletonReplayMatrix.length = 19 := rfl
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound]
 -/
@@ -2728,7 +2744,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered'
 
 /--
 info: 'Lean4Lean.InductiveReplayFixtures.singletonFixedReplays' depends on axioms: [propext,
- sorryAx,
  Classical.choice,
  Quot.sound,
  PersistentHashMap.findAux_isSome,
@@ -2762,9 +2777,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.singletonNormalizationReplays' depends
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
@@ -2795,9 +2813,12 @@ info: 'Lean4Lean.InductiveReplayFixtures.singletonReplayMatrix' depends on axiom
  Level.hasMVar_eq,
  Level.hasParam_eq,
  Level.instLawfulBEqLevel,
+ Level.isExplicitSubsumedAux_eq,
+ Level.normalize_eq,
  PersistentArray.toList'_push,
  PersistentHashMap.findAux_isSome,
  Syntax.structEq_eq,
+ Std.TreeMap.all_eq_all_toList,
  PersistentHashMap.WF.find?_eq,
  PersistentHashMap.WF.toList'_insert]
 -/
diff --git a/Lean4Lean/Verify/EquivManager.lean b/Lean4Lean/Verify/EquivManager.lean
index 4634eea2..627b3b10 100644
--- a/Lean4Lean/Verify/EquivManager.lean
+++ b/Lean4Lean/Verify/EquivManager.lean
@@ -261,21 +261,19 @@ theorem toNode.WF :
 
 theorem isEquiv.WF :
     M.WF env Us Δ m (isEquiv useHash e₁ e₂) fun b _ => b → IsDefEqE env Us Δ e₁ e₂ := by
-  unfold isEquiv; extract_lets F1 F2 F3
-  split <;> [exact .pure fun _ => ptrEqExpr_eq ‹_› ▸ .rfl; skip]
-  simp [F3]; split <;> [exact .pure nofun; skip]
-  simp [F2]; split
+  unfold isEquiv; split <;> [exact .pure fun _ => ptrEqExpr_eq ‹_› ▸ .rfl; skip]
+  split <;> [exact .pure nofun; split]
   · rename_i h; refine .pure ?_
-    unfold Expr.isBVar at h; split at h <;> cases h.1; split at h <;> cases h.2
+    simp only [Bool.and_eq_true, Expr.isBVar] at h
+    split at h <;> cases h.1; split at h <;> cases h.2
     simp [Expr.bvarIdx!]; rintro ⟨⟩; exact .rfl
-  unfold F1
   refine toNode.WF.bind fun i₁ _ _ a1 => find.WF.bind fun j₁ _ le₁ a2 => ?_
   refine toNode.WF.bind fun i₂ _ le₂ b1 => find.WF.bind fun j₂ m₀ le₃ b2 => ?_
   refine .stateWF fun wf => ?_
   replace a1 := le₁.trans le₂ |>.trans le₃ |>.toNodeMap a1
   replace a2 := le₂.trans le₃ |>.uf a2
   replace b1 := le₃.toNodeMap b1
-  extract_lets F4 F5
+  extract_lets F4
   split
   · rename_i h; simp at h; cases h; refine .pure fun _ => wf.defeq a1 b1 (a2.trans b2.symm)
   have {m b} (le₄ : m₀ ≤ m) (H : b = true → IsDefEqE env Us Δ e₁ e₂) :
@@ -288,7 +286,7 @@ theorem isEquiv.WF :
     have ⟨r₂, hr₂⟩ := wf.wf.1 <| b2.lt_size.1 <| wf.wf.2 ⟨_, b1⟩
     suffices IsDefEqE env Us Δ r₁ r₂ from have ⟨wf, h⟩ := merge.WF wf this hr₁ hr₂; ⟨wf, h, H⟩
     exact (wf.defeq a1 hr₁ a2).symm.trans <| .trans (H ‹_›) (wf.defeq b1 hr₂ b2)
-  simp; unfold F5; split
+  simp; split
   · apply this .rfl; simp; rintro rfl rfl; exact .rfl
   · apply this .rfl; simp; rintro rfl; exact .rfl
   · apply this .rfl; simp; rintro rfl; exact .rfl
diff --git a/Lean4Lean/Verify/Expr.lean b/Lean4Lean/Verify/Expr.lean
index 36055465..02aaeefd 100644
--- a/Lean4Lean/Verify/Expr.lean
+++ b/Lean4Lean/Verify/Expr.lean
@@ -73,7 +73,7 @@ theorem beq_refl (s : Substring.Raw) : s == s := by
   termination_by n.byteIdx - i.byteIdx
   refine ⟨?_, loop⟩
   obtain h | h := Nat.le_or_le s.repair.startPos.byteIdx s.repair.stopPos.byteIdx
-  · rw [Nat.add_sub_cancel' h]
+  · simp only [Nat.add_sub_cancel' h, decide_eq_true_eq]
     apply String.Pos.Raw.IsValid.le_rawEndPos
     simp [Substring.Raw.repair]; split <;> simp [*]
   · simp [Nat.sub_eq_zero_of_le h]
@@ -82,7 +82,8 @@ theorem beq_refl (s : Substring.Raw) : s == s := by
 
 open private substrEq.loop from Init.Data.String.Basic in
 theorem beq_symm {s t : Substring.Raw} : s == t → t == s := by
-  simp +contextual [(· == ·), Substring.Raw.beq, Substring.Raw.bsize, String.Pos.Raw.substrEq]
+  simp +contextual [(· == ·), Substring.Raw.beq, String.Pos.Raw.substrEq]
+  simp [Substring.Raw.bsize]
   let rec loop {s s' b b' i n} :
       substrEq.loop s s' ⟨b + i⟩ ⟨b' + i⟩ ⟨b + n⟩ ↔
       substrEq.loop s' s ⟨b' + i⟩ ⟨b + i⟩ ⟨b' + n⟩ := by
@@ -98,7 +99,8 @@ theorem beq_symm {s t : Substring.Raw} : s == t → t == s := by
 
 open private substrEq.loop from Init.Data.String.Basic in
 theorem beq_trans {s t : Substring.Raw} : s == t → t == u → s == u := by
-  simp +contextual [(· == ·), Substring.Raw.beq, Substring.Raw.bsize, String.Pos.Raw.substrEq]
+  simp +contextual [(· == ·), Substring.Raw.beq, String.Pos.Raw.substrEq]
+  simp [Substring.Raw.bsize]
   let ⟨s, ⟨b⟩, e⟩ := s.repair
   let ⟨s2, ⟨b2⟩, e2⟩ := t.repair
   let ⟨s3, ⟨b3⟩, e3⟩ := u.repair
@@ -271,6 +273,9 @@ private theorem BitVec.add_shiftLeft_eq_or_of_toNat_lt_two_pow
       exact BitVec.getLsbD_eq_false_of_toNat_lt_two_pow h (Nat.le_of_not_gt hin)
     simp [hx]
 
+set_option allowUnsafeReducibility true
+attribute [local reducible] Data
+
 private theorem mkData_flags (H : br ≤ 2 ^ 20 - 1) :
     (mkData h br d fv ev lv lp).hasFVar = fv ∧
     (mkData h br d fv ev lv lp).hasExprMVar = ev ∧
@@ -676,6 +681,9 @@ attribute [simp] mkConst mkBVar mkSort mkFVar mkMVar mkMData mkProj mkApp mkLamb
   updateApp! updateFVar! updateConst! updateSort! updateMData! updateProj!
   updateForall! updateForallE! updateLambda! updateLambdaE! updateLetE! updateLet!
 
+set_option allowUnsafeReducibility true
+attribute [local reducible] Data
+
 theorem mkData_looseBVarRange (H : br ≤ 2^20 - 1) :
     (mkData h br d fv ev lv lp).looseBVarRange.toNat = br := by
   rw [mkData_eq, mkData', if_pos H]; dsimp only [Data.looseBVarRange, -Nat.reducePow]
diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean
index 22f828ff..095c602b 100644
--- a/Lean4Lean/Verify/Level.lean
+++ b/Lean4Lean/Verify/Level.lean
@@ -1,90 +1,13 @@
 import Lean4Lean.Theory.VLevel
 import Lean4Lean.Level
+import Lean4Lean.Verify.Name
+import Lean4Lean.Verify.LevelStd
 import Lean4Lean.Verify.Axioms
 import Std.Tactic.BVDecide
 import Std.Data.TreeMap.Lemmas
 
 namespace Lean
 
-namespace Name
-open Std
-
-instance : TransCmp cmp := by
-  have eq_swap {a b : Name} : a.cmp b = (b.cmp a).swap := by
-    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp]
-    | str a₁ a₂ ih | num a₁ a₂ ih =>
-      rw [ih]; cases b₁.cmp a₁ <;> simp [← OrientedOrd.eq_swap]
-  refine { eq_swap, isLE_trans {a b c} := ?_ }
-  have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁} {a₂ b₂ c₂ : α}
-      (H1 : (cmp a₁ b₁).isLE → (cmp b₁ c₁).isLE → (cmp a₁ c₁).isLE)
-      (H2 : (cmp c₁ a₁).isLE → (cmp a₁ b₁).isLE → (cmp c₁ b₁).isLE)
-      (H3 : (cmp b₁ c₁).isLE → (cmp c₁ a₁).isLE → (cmp b₁ a₁).isLE) :
-      ((cmp a₁ b₁).then (compare a₂ b₂)).isLE →
-      ((cmp b₁ c₁).then (compare b₂ c₂)).isLE →
-      ((cmp a₁ c₁).then (compare a₂ c₂)).isLE := by
-    simp [Ordering.isLE_then_iff_and]
-    intro h1 h2 h3 h4
-    refine have := H1 h1 h3; ⟨this, ?_⟩
-    obtain eq | eq := Ordering.isLE_iff_eq_lt_or_eq_eq.1 this; · exact .inl eq
-    obtain h2 | h2 := h2
-    · rw [@eq_swap c₁, eq, @eq_swap _ a₁, h2] at H3; simp [h3] at H3
-    obtain h4 | h4 := h4
-    · rw [eq_swap, eq, @eq_swap c₁, h4] at H2; simp [h1] at H2
-    exact .inr (TransCmp.isLE_trans h2 h4)
-  refine (?_ : _ ∧ ((cmp c a).isLE → (cmp a b).isLE → (cmp c b).isLE) ∧
-    ((cmp b c).isLE → (cmp c a).isLE → (cmp b a).isLE)).1
-  induction a generalizing b c with
-    obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] at * <;>
-    obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [cmp] at *
-  | str a₁ a₂ ih | num a₁ a₂ ih =>
-    let ⟨h1, h2, h3⟩ := @ih b₁ c₁
-    exact ⟨this h1 h2 h3, this h2 h3 h1, this h3 h1 h2⟩
-
-instance : LawfulBEqCmp cmp where
-  compare_eq_iff_beq {a b} := by
-    simp; refine ⟨?_, fun h => h ▸ ReflCmp.compare_self⟩
-    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp]
-    | str a₁ a₂ ih | num a₁ a₂ ih =>
-      refine ?_ ∘ Ordering.then_eq_eq.1
-      simp +contextual; exact fun h _ => ih h
-
-instance : TransCmp quickCmp where
-  eq_swap {a b} := by
-    simp [quickCmp]
-    rw [OrientedOrd.eq_swap]
-    cases compare b.hash a.hash <;> simp
-    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux]
-    | str a₁ a₂ ih | num a₁ a₂ ih =>
-      rw [OrientedOrd.eq_swap]
-      cases compare b₂ a₂ <;> simp [ih]
-  isLE_trans {a b c} := by
-    have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁ : α} {a₂ b₂ c₂}
-        (H : (quickCmpAux a₂ b₂).isLE → (quickCmpAux b₂ c₂).isLE → (quickCmpAux a₂ c₂).isLE) :
-        ((compare a₁ b₁).then (quickCmpAux a₂ b₂)).isLE →
-        ((compare b₁ c₁).then (quickCmpAux b₂ c₂)).isLE →
-        ((compare a₁ c₁).then (quickCmpAux a₂ c₂)).isLE := by
-      simp [Ordering.isLE_then_iff_and]
-      intro h1 h2 h3 h4
-      refine ⟨TransCmp.isLE_trans h1 h3, ?_⟩
-      refine h2.elim (fun h2 => .inl <| TransCmp.lt_of_lt_of_isLE h2 h3) fun h2 => ?_
-      refine h4.elim (fun h4 => .inl <| TransCmp.lt_of_isLE_of_lt h1 h4) fun h4 => .inr (H h2 h4)
-    apply this
-    induction a generalizing b c with
-      obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] at * <;>
-      obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [quickCmpAux] at *
-    | str a₁ a₂ ih | num a₁ a₂ ih => apply this ih
-
-instance : LawfulBEqCmp quickCmp where
-  compare_eq_iff_beq {a b} := by
-    simp; refine ⟨fun h => ?_, fun h => h ▸ ReflCmp.compare_self⟩
-    replace h := (Ordering.then_eq_eq.1 h).2; revert h
-    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux]
-    | str a₁ a₂ ih | num a₁ a₂ ih =>
-      refine ?_ ∘ Ordering.then_eq_eq.1
-      simp +contextual; exact fun _ => ih
-
-end Name
-
 namespace Level
 open Lean4Lean
 
@@ -112,6 +35,9 @@ attribute [simp] mkLevelSucc mkLevelMax mkLevelIMax updateSucc! updateMax! updat
     unfold getOffsetAux getOffset'; split <;> simp
     rw [go]; simp [Nat.add_right_comm, Nat.add_assoc]
 
+set_option allowUnsafeReducibility true
+attribute [local reducible] Data
+
 theorem mkData_depth (H : d < 2 ^ 24) : (mkData h d hmv hp).depth.toNat = d := by
   rw [mkData_eq, mkData', if_neg (Nat.not_lt.2 (Nat.le_sub_one_of_lt H)), Data.depth]
   have : d.toUInt64.toUInt32.toNat = d := by simp; omega
@@ -176,12 +102,11 @@ theorem getUndefParam_none {l : Level} (hmv : l.hasMVar' = false) :
     l.getUndefParam Us = none → ∃ u', VLevel.ofLevel Us l = some u' := by
   suffices ∀ s, ((l.forEach (getUndefParam.F Us)).run s).run.snd = none → s = none ∧ _ from
     (this _ · |>.2)
-  have {l} (hmv : l.hasMVar' = false)
-      {g} (H : ∀ {s'}, (g.run s').run.snd = none → s' = none ∧
+  have {l} (hmv : l.hasMVar' = false) {g}
+      (H : ∀ {s'}, (g.run s').run.snd = none → s' = none ∧
         (((getUndefParam.F Us l).run none).run = (true, none) →
           ∃ u', VLevel.ofLevel Us l = some u')) (s) :
-      ((do if (!(← getUndefParam.F Us l)) = true then pure PUnit.unit else g)
-        |>.run s).run.snd = none →
+      ((do if !(← getUndefParam.F Us l) then pure () else g) |>.run s).run.snd = none →
       s = none ∧ ∃ u', VLevel.ofLevel Us l = some u' := by
     simp; split <;> rename_i h
     · simp; revert h
@@ -243,6 +168,8 @@ namespace Normalize
 attribute [local instance] Lean.Level.Normalize.instOrdName_lean4Lean
 
 local instance : Std.TransCmp (α := Name) compare := inferInstanceAs (Std.TransCmp Name.cmp)
+local instance : Std.LawfulBEqCmp (α := Name) compare :=
+  inferInstanceAs (Std.LawfulBEqCmp Name.cmp)
 local instance : Std.LawfulBEqCmp (α := List Name) compare :=
   inferInstanceAs (Std.LawfulBEqCmp (List.compareLex Name.cmp))
 
@@ -256,10 +183,56 @@ instance : LawfulBEq VarNode where
 @[reducible] local instance : GetElem? NormLevel (List Name) Node (fun m a => a ∈ m) :=
   inferInstanceAs (GetElem? (Std.TreeMap _ _ compare) ..)
 
+inductive Extend1 : List α → α → List α → Prop
+  | mk : Extend1 (l₁ ++ l₂) v (l₁ ++ v :: l₂)
+
+theorem Extend1.base : Extend1 l v (v::l) := .mk (l₁ := [])
+theorem Extend1.cons (H : Extend1 l v l') : Extend1 (a::l) v (a::l') :=
+  let .mk := H; .mk (l₁ := _::_)
+
+theorem Extend1.mem (H : Extend1 p a p') : b ∈ p' ↔ b = a ∨ b ∈ p := by cases H; simp [or_left_comm]
+
+theorem Extend1.length (H : Extend1 p a p') : p'.length = p.length + 1 := by
+  cases H; simp [Nat.add_assoc]
+
+theorem Extend1.of_mem (h : a ∈ p') : ∃ p, Extend1 p a p' := by
+  obtain ⟨_, _, rfl, _⟩ := List.eq_append_cons_of_mem h; exact ⟨_, .mk⟩
+
+theorem Extend1.orderedInsert (H : orderedInsert cmp v p = some p') : Extend1 p v p' := by
+  induction p generalizing p' with simp [Normalize.orderedInsert] at H
+  | nil => exact H ▸ .base
+  | cons _ _ ih =>
+    split at H <;> [(cases H; exact .base); cases H; skip]
+    simp at H; obtain ⟨_, H, rfl⟩ := H; exact (ih H).cons
+
+inductive Extend? : List α → α → List α → Prop
+  | mk1 : Extend1 l v l' → Extend? l v l'
+  | mk0 : v ∈ l → Extend? l v l
+
+theorem Extend?.cons (H : Extend? l v l') : Extend? (a::l) v (a::l') := by
+  cases H with
+  | mk1 H => exact .mk1 H.cons
+  | mk0 H => exact .mk0 (.tail _ H)
+
+theorem Extend?.mem (H : Extend? p a p') : b ∈ p' ↔ b = a ∨ b ∈ p := by
+  cases H with
+  | mk1 H => exact H.mem
+  | mk0 H => simp; rintro rfl; exact H
+
+theorem Extend?.orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] :
+    Extend? p v ((orderedInsert cmp v p).getD p) := by
+  induction p with simp [Normalize.orderedInsert]
+  | nil => exact .mk1 .base
+  | cons _ _ ih =>
+    split
+    · exact .mk1 .base
+    · simp_all; exact .mk0 (.head _)
+    · revert ih; cases Normalize.orderedInsert .. <;> exact .cons
+
 section
 variable (ls : List Name) (ρ : List Nat) in
 def evalParam (x : Name) : Nat :=
-let i := ls.idxOf x; if i < ls.length then ρ[i]?.getD 0 else 0
+  let i := ls.idxOf x; if i < ls.length then ρ[i]?.getD 0 else 0
 
 theorem evalParam_eq (hv : ls.idxOf x < ls.length) :
     evalParam ls ρ x = ρ[List.idxOf x ls]?.getD 0 := if_pos hv
@@ -305,19 +278,6 @@ theorem evalPath_mono (h : n ≤ m) :
 theorem evalPath_le : evalPath ls ρ path n ≤ m ↔ (allNZ ls ρ path → n ≤ m) := by
   simp [evalPath]; split <;> simp [*]
 
-variable (ls : List Name) (ρ : List Nat) in
-inductive EvalPaths : List Name → Nat → Prop
-  | nil : EvalPaths [] n
-  | insert : orderedInsert Name.cmp a path = some path' →
-    evalPath ls ρ path (evalParam ls ρ a) ≤ n → EvalPaths path n → EvalPaths path' n
-
-theorem EvalPaths.mono (h : n ≤ n') : EvalPaths ls ρ path n → EvalPaths ls ρ path n'
-  | .nil => .nil
-  | .insert h1 h2 h3 => .insert h1 (Nat.le_trans h2 h) (h3.mono h)
-
-theorem EvalPaths.max : EvalPaths ls ρ path n → EvalPaths ls ρ path (max' n m) :=
-  .mono (Nat.le_max_left ..)
-
 variable (ls : List Name) (ρ : List Nat) in
 def NormLevel.eval (l : NormLevel) : Nat :=
   l.foldl (init := 0) fun n a b => max' n (evalPath ls ρ a (b.eval ls ρ))
@@ -341,7 +301,11 @@ theorem NormLevel.addNode_contains_self : (addNode v k path acc).contains path :
   simp [addNode]; split <;> simp
 
 theorem NormLevel.addConst_contains (H : acc.contains x) : (addConst k path acc).contains x := by
-  simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_modify]
+  simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_alter]; split <;> simp
+
+theorem NormLevel.addConst_contains_self (h : k ≠ 0) (h2 : ¬(k = 1 ∧ path ≠ [])) :
+    (addConst k path acc).contains path := by
+  simp [addConst, h, h2]; split <;> simp
 
 theorem normalizeAux_contains (H : acc.contains x) : (normalizeAux u path k acc).contains x := by
   unfold normalizeAux; split
@@ -363,64 +327,208 @@ theorem normalizeAux_contains (H : acc.contains x) : (normalizeAux u path k acc)
     · exact H
     · exact NormLevel.addVar_contains H
 
-theorem imax_max : Nat.imax a (max' b c) = max' (Nat.imax a b) (Nat.imax a c) := by
-  simp [Nat.imax]; symm; split <;> simp [*]; split <;> simp [*, Nat.max_eq_max]
+theorem imax_max : Lean.Nat.imax a (max' b c) = max' (Lean.Nat.imax a b) (Lean.Nat.imax a c) := by
+  simp [Lean.Nat.imax]; symm; split <;> simp [*]; split <;> simp [*, Nat.max_eq_max]
   rw [Nat.max_left_comm b, ← Nat.max_assoc, Nat.max_self]
 
-theorem imax_imax : Nat.imax a (Nat.imax b c) = max' (Nat.imax a c) (Nat.imax b c) := by
-  simp [Nat.imax]; by_cases h : c = 0 <;> simp [*, Nat.max_eq_max]
+theorem imax_imax : Lean.Nat.imax a (Lean.Nat.imax b c) =
+    max' (Lean.Nat.imax a c) (Lean.Nat.imax b c) := by
+  simp [Lean.Nat.imax]; by_cases h : c = 0 <;> simp [*, Nat.max_eq_max]
   rw [Nat.max_left_comm c, Nat.max_self]
 
-theorem mem_orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] :
-    b ∈ (orderedInsert cmp a ls).getD ls ↔ b = a ∨ b ∈ ls := by
-  induction ls <;> simp [orderedInsert]; split <;> simp_all [or_left_comm]
-
-theorem allNZ_orderedInsert :
-    allNZ ls ρ ((orderedInsert Name.cmp a path).getD path) = allNZ ls ρ (a :: path) := by
-  rw [Bool.eq_iff_iff]; simp [allNZ, mem_orderedInsert]
-
-theorem evalPath_orderedInsert :
-    evalPath ls ρ ((orderedInsert Name.cmp a path).getD path) = evalPath ls ρ (a :: path) := by
-  ext n; simp [evalPath, allNZ_orderedInsert]
-
-theorem EvalPaths.of_mem (hm : v ∈ path) (H : EvalPaths ls ρ path n) :
-    ∃ path₁ path₂, (∀ x ∈ path₁, x ∈ path) ∧
-      orderedInsert Name.cmp v path₁ = some path₂ ∧
-      evalPath ls ρ path₁ (evalParam ls ρ v) ≤ n ∧
-      EvalPaths ls ρ path₁ n := by
-  induction H with | nil => cases hm | insert h1 h2 h3 ih
-  obtain rfl | hm := (h1 ▸ mem_orderedInsert).1 hm
-  · exact ⟨_, _, fun _ h => (h1 ▸ mem_orderedInsert).2 (.inr h), h1, h2, h3⟩
-  · let ⟨_, _, a1, a2, a3, a4⟩ := ih hm
-    exact ⟨_, _, fun _ h => (h1 ▸ mem_orderedInsert).2 (.inr (a1 _ h)), a2, a3, a4⟩
+protected theorem Extend?.allNZ (H : Extend? p a p') : allNZ ls ρ p' = allNZ ls ρ (a :: p) := by
+  rw [Bool.eq_iff_iff]; simp [allNZ, H.mem]
+
+protected theorem Extend?.evalPath (H : Extend? p a p') :
+    evalPath ls ρ p' = evalPath ls ρ (a :: p) := by ext n; simp [evalPath, H.allNZ]
 
 theorem ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m :=
   Nat.le_antisymm ((H _).2 (Nat.le_refl _)) ((H _).1 (Nat.le_refl _))
 
 theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _)
 
-theorem NormLevel.addConst_eval
-    (H : acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) :
+/-- Condition sets are strictly sorted, which is what makes `subset` a decision procedure
+for inclusion: it is built up by `orderedInsert` from the empty set. -/
+def Sorted (l : List Name) : Prop := l.Pairwise (compare · · = .lt)
+
+nonrec theorem Sorted.nil : Sorted [] := .nil
+
+theorem Sorted.of_cons (h : Sorted (a :: l)) : Sorted l := (List.pairwise_cons.1 h).2
+
+theorem Sorted.head (h : Sorted (a :: l)) : ∀ b ∈ l, compare a b = .lt :=
+  (List.pairwise_cons.1 h).1
+
+theorem Sorted.erase (h : Sorted l) : Sorted (l.erase a) := h.sublist (List.erase_sublist ..)
+
+theorem Sorted.nodup (h : Sorted l) : l.Nodup :=
+  h.imp <| by rintro _ _ hab rfl; rw [Std.ReflOrd.compare_self] at hab; cases hab
+
+theorem Sorted.orderedInsert (h : Sorted l) (he : orderedInsert Name.cmp a l = some l') :
+    Sorted l' := by
+  induction l generalizing l' with | nil => cases he; exact .cons (by simp) .nil | cons b l ih
+  simp only [Normalize.orderedInsert] at he
+  split at he <;> rename_i hab
+  · cases he
+    refine .cons (fun c hc => ?_) h
+    obtain rfl | hc := List.mem_cons.1 hc
+    · exact hab
+    · exact Std.TransCmp.lt_trans hab (h.head _ hc)
+  · cases he
+  · simp only [Option.map_eq_some_iff] at he
+    obtain ⟨l'', he, rfl⟩ := he
+    refine .cons (fun c hc => ?_) (ih h.of_cons he)
+    -- `c` is either `a`, which is above `b`, or an element of `l`
+    obtain rfl | hc := (Extend1.orderedInsert he).mem.1 hc
+    · exact Std.OrientedCmp.lt_of_gt hab
+    · exact h.head _ hc
+
+/-- The well-formedness invariant of the `NormLevel` maps produced by `normalizeAux`:
+every variable recorded at a key is an element of that key, and every nonempty key `p`
+extends another key of the map by a single variable that is recorded at `p`.
+The latter is what makes the sublevels expressible by `imax` chains (see the reconstruction
+comment in `Lean4Lean.Level`), and it lets `addConst` drop `C(p, 1)` for `p ≠ []`. -/
+def NormLevel.WF (s : NormLevel) : Prop :=
+  ∀ p n, s.get? p = some n →
+    (p ≠ [] → ∃ v p', Extend1 p' v p ∧ (p' = [] ∨ s.contains p') ∧ ∃ x ∈ n.var, x.var = v) ∧
+    (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p
+
+theorem NormLevel.WF.of_mem (hm : v ∈ path) (H : WF s) (hp : s.contains path) :
+    ∃ path₁ path₂ n, (∀ x ∈ path₁, x ∈ path) ∧
+      Extend1 path₁ v path₂ ∧ (path₁ = [] ∨ s.contains path₁) ∧ s.get? path₂ = some n ∧
+      ∃ x ∈ n.var, x.var = v := by
+  generalize eq : path.length = n
+  induction n generalizing path with | zero => simp at eq; subst path; cases hm | succ n ih
+  have ⟨_, hp'⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp)
+  have ⟨_, _, a1, a2, a3⟩ := (H _ _ hp').1 (by rintro rfl; cases hm)
+  obtain rfl | hm := a1.mem.1 hm
+  · exact ⟨_, _, _, fun _ h => a1.mem.2 (.inr h), a1, a2, hp', a3⟩
+  · -- the parent is in the map, since `v` occurs in it and so it is not the root
+    have ⟨_, _, _, b1, b2⟩ := ih hm (a2.resolve_left (by rintro rfl; cases hm))
+      (by cases a1; simp at eq ⊢; exact Nat.succ_inj.1 eq)
+    exact ⟨_, _, _, fun _ h => a1.mem.2 (.inr (b1 _ h)), b2⟩
+
+theorem NormLevel.WF.sortedOf {s : NormLevel} (wf : s.WF) (H : path = [] ∨ s.contains path) :
+    Sorted path := by
+  obtain rfl | h := H
+  · exact Sorted.nil
+  · obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans h)
+    exact (wf _ _ hn).2.2
+
+theorem VarNode.mem_addVar :
+    (∃ x ∈ VarNode.addVar v k l, x.var = u) ↔ v = u ∨ (∃ x ∈ l, x.var = u) := by
+  induction l with simp [addVar] | cons x l ih; split <;> simp_all [or_left_comm]
+
+theorem NormLevel.addVar_wf (hv : v ∈ path) (wf : acc.WF) :
+    (addVar v k path acc).WF := by
+  simp [addVar, WF, Std.TreeMap.getElem?_modify, Std.TreeMap.mem_modify] at wf ⊢
+  intro p n; split <;> [simp; apply wf]
+  subst p; rintro _ h rfl; have ⟨a1, a2, a3⟩ := wf _ _ h
+  refine ⟨fun h => ?_, fun _ h => ?_, a3⟩
+  · have ⟨_, _, b1, b2, b3⟩ := a1 h; exact ⟨_, _, b1, b2, VarNode.mem_addVar.2 (.inr b3)⟩
+  · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩
+    · exact eq ▸ hv
+    · exact eq ▸ a2 _ h
+
+theorem NormLevel.addNode_wf (H : Extend1 path v path') (hs : Sorted path')
+    (hacc : path = [] ∨ acc.contains path) (wf : acc.WF) : (addNode v k path' acc).WF := by
+  simp [addNode, WF, Std.TreeMap.getElem?_alter, Std.TreeMap.mem_alter] at *
+  intro p n; split
+  · subst p; split <;> rintro ⟨⟩ <;> simp
+    · exact ⟨fun _ => ⟨_, _, H, hacc.imp id fun h _ => h, rfl⟩, H.mem.2 (.inl rfl), hs⟩
+    · obtain ⟨a1, a2, a3⟩ := wf _ _ ‹_›; refine ⟨fun h => ?_, fun _ h => ?_, a3⟩
+      · have ⟨_, _, b1, b2, b3⟩ := a1 h
+        exact ⟨_, _, b1, b2.imp id fun h _ => h, VarNode.mem_addVar.2 (.inr b3)⟩
+      · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩
+        · exact H.mem.2 (.inl eq.symm)
+        · exact eq ▸ a2 _ h
+  · intro h; have ⟨a1, a2, a3⟩ := wf _ _ h; refine ⟨fun h => ?_, a2, a3⟩
+    have ⟨_, _, b1, b2, b3⟩ := a1 h; refine ⟨_, _, b1, ?_, b3⟩
+    split <;> [split <;> simp; exact b2]
+
+/-- `WF` survives an update that only adds keys and preserves each node's variables, provided
+any key it adds is the root, where the parent condition is vacuous. -/
+theorem NormLevel.WF.update {s s' : NormLevel} (wf : s.WF)
+    (hk : ∀ q, s.contains q → s'.contains q)
+    (hv : ∀ p n, s'.get? p = some n →
+      (∃ n₀, s.get? p = some n₀ ∧ n.var = n₀.var) ∨ (p = [] ∧ n.var = [])) : s'.WF := by
+  intro p n hn
+  rcases hv p n hn with ⟨n₀, h₀, hvar⟩ | ⟨rfl, hvar⟩
+  · obtain ⟨a1, a2, a3⟩ := wf _ _ h₀
+    refine ⟨fun h => ?_, fun v hv => a2 v (hvar ▸ hv), a3⟩
+    obtain ⟨v, p', b1, b2, b3⟩ := a1 h
+    exact ⟨v, p', b1, b2.imp id (hk _), hvar ▸ b3⟩
+  · exact ⟨absurd rfl, by simp [hvar], Sorted.nil⟩
+
+theorem NormLevel.addConst_wf (hp : path = [] ∨ acc.contains path) (H : acc.WF) :
+    (addConst k path acc).WF := by
+  simp only [addConst]; split <;> [exact H; skip]
+  refine H.update (fun q hq => ?_) fun p n hn => ?_
+  · rw [Std.TreeMap.contains_alter]; split <;> [split <;> simp; simp [hq]]
+  · rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn
+    split at hn <;> [rename_i hpe; exact .inl ⟨n, hn, rfl⟩]
+    cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hpe)
+    -- `alter` creates a node only at the root, since otherwise `path` is already a key
+    match hpath : acc[path]?, hp with
+    | some n', _ => rw [hpath] at hn; cases hn; exact .inl ⟨n', hpath, rfl⟩
+    | none, .inl hr => rw [hpath] at hn; cases hn; exact .inr ⟨hr, rfl⟩
+    | none, .inr h => simp [Std.TreeMap.mem_iff_isSome_getElem?, hpath] at h
+
+theorem normalizeAux_wf (H : path = [] ∨ acc.contains path) (wf : acc.WF) :
+    (normalizeAux u path k acc).WF := by
+  unfold normalizeAux; split
+  · exact NormLevel.addConst_wf H wf
+  · exact NormLevel.addConst_wf H wf
+  · exact normalizeAux_wf H wf
+  · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf)
+  · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf)
+  · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf)
+  · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf)
+  · split <;> rename_i eq <;> [skip; (dsimp; split)]
+    · exact normalizeAux_wf (.inr NormLevel.addNode_contains_self)
+        (NormLevel.addNode_wf (.orderedInsert eq) ((wf.sortedOf H).orderedInsert eq)
+        (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf))
+    · exact normalizeAux_wf H wf
+    · refine normalizeAux_wf (H.imp id NormLevel.addVar_contains) (NormLevel.addVar_wf ?_ wf)
+      exact (eq ▸ Extend?.orderedInsert).mem.2 (.inl rfl)
+  · exact wf
+  · exact wf
+  · split <;> rename_i eq <;> [skip; split]
+    · exact NormLevel.addNode_wf (.orderedInsert eq) ((wf.sortedOf H).orderedInsert eq)
+        (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)
+    · exact wf
+    · exact NormLevel.addVar_wf ((eq ▸ Extend?.orderedInsert).mem.2 (.inl rfl)) wf
+
+theorem NormLevel.addConst_eval (H : path = [] ∨ acc.contains path) (wf : acc.WF) :
     (addConst k path acc).eval ls ρ = max' (acc.eval ls ρ) (evalPath ls ρ path k) := by
   simp [addConst]; split <;> rename_i h
-  · obtain rfl | ⟨rfl, _⟩ := h
+  · obtain rfl | ⟨rfl, hne⟩ := h
     · simp [evalPath]
-    · let a::path := path; let .insert h1 le h3 := le
-      have := h1 ▸ evalPath_orderedInsert (ls := ls) (ρ := ρ); simp at this
-      rw [this, Nat.max_eq_left]; simp [evalPath]; split <;> [rename_i h; simp]
-      let ⟨h1, h2⟩ := allNZ_cons.1 h; exact Nat.le_trans h1 (evalPath_le.1 le h2)
+    · -- `C(p, 1)` for `p ≠ []` is already dominated: `WF` puts a variable of `p` at `p`,
+      -- and along a nonzero path that variable is at least 1
+      rw [Nat.max_eq_left]; refine evalPath_le.2 fun nz => le_ext_le fun n le => ?_
+      have H := H.resolve_left hne
+      rw [← Std.TreeMap.isSome_getElem?_eq_contains, Option.isSome_iff_exists] at H
+      let ⟨v, H⟩ := H; have ⟨_, _, a1, a2, _, a3, rfl⟩ := (wf _ _ H).1 ‹_›
+      have := (Node.eval_le.1 (evalPath_le.1 (eval_le.1 le _ _ H) nz)).2 _ a3
+      simp [allNZ] at nz
+      exact Nat.le_trans (nz _ (a1.mem.2 (.inl rfl))) (Nat.le_of_add_right_le this)
   · refine ext_le fun x => ?_
-    rw [← Std.TreeMap.isSome_getElem?_eq_contains, Option.isSome_iff_exists] at H; let ⟨v, H⟩ := H
-    simp [eval_le, Nat.max_le, Std.TreeMap.getElem?_modify, evalPath_le, Node.eval_le, H]
-    refine ⟨fun h1 => ?_, fun ⟨h1, h2⟩ a b => ?_⟩
-    · have := h1 path; simp [Nat.max_le] at this
-      refine ⟨fun a b h3 h4 => ?_, fun h => (this h).1.1⟩
-      specialize h1 a; split at h1
-      · subst a; cases H.symm.trans h3; exact ⟨(this h4).1.2, (this h4).2⟩
-      · exact h1 _ h3 h4
-    · split
-      · subst a; rintro ⟨⟩ nz; simp [Nat.max_le, nz, h2]; exact h1 _ _ H nz
-      · exact h1 _ _
+    simp [eval_le, Nat.max_le, Std.TreeMap.getElem?_alter, evalPath_le, Node.eval_le]
+    refine ⟨fun H => ⟨fun a b h nz => ?_, fun nz => ?_⟩, fun ⟨H1, H2⟩ a b h nz => ?_⟩
+    · have := H a; split at this
+      · subst a; rw [h] at this
+        obtain ⟨hc, hv⟩ := this _ rfl nz
+        exact ⟨Nat.le_trans (Nat.le_max_right ..) hc, hv⟩
+      · exact this _ h nz
+    · have := H path; rw [if_pos rfl] at this; split at this <;>
+        refine Nat.le_trans ?_ ((this _ rfl nz).1)
+      · exact Nat.le_refl _
+      · exact Nat.le_max_left ..
+    · split at h
+      · subst a; split at h <;> cases h <;> [exact ⟨H2 nz, by simp⟩; rename_i n hn]
+        obtain ⟨hc, hv⟩ := H1 _ _ hn nz
+        exact ⟨Nat.max_le.2 ⟨H2 nz, hc⟩, hv⟩
+      · exact H1 _ _ h nz
 
 theorem VarNode.addVar_le : (∀ vn ∈ VarNode.addVar v k l, vn.eval ls ρ ≤ x) ↔
     evalParam ls ρ v + k ≤ x ∧ (∀ vn ∈ l, vn.eval ls ρ ≤ x) := by
@@ -460,574 +568,3242 @@ theorem NormLevel.addVar_eval (H : acc.contains path) : (addVar v k path acc).ev
     · subst a; cases h; simp_all [VarNode.addVar_le]; grind
     · grind
 
+/-- The invariant threaded through `normalizeAux`: the current path is either the root, which
+`addConst` creates on demand, or already a key of the map, created by an earlier `addNode`.
+`addVar` is only reached in the second case, since it runs only when `path` already contains
+the variable being added. -/
 theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u')
-    (H : acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) :
+    (H : path = [] ∨ acc.contains path) (wf : acc.WF) :
     (normalizeAux u path k acc).eval ls ρ =
     max' (acc.eval ls ρ) (evalPath ls ρ path (u'.eval ρ + k)) := by
   unfold normalizeAux; split
-  · cases hu; simp [NormLevel.addConst_eval H le, VLevel.eval]
+  · cases hu; simp [NormLevel.addConst_eval H wf, VLevel.eval]
   · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu
-    simp [VLevel.eval, Nat.imax, NormLevel.addConst_eval H le]
+    simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval H wf]
   · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu
-    rw [normalizeAux_eval hu H le, Nat.add_succ, ← Nat.succ_add]; rfl
+    rw [normalizeAux_eval hu H wf, Nat.add_succ, ← Nat.succ_add]; rfl
   · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu
-    rw [normalizeAux_eval hv (normalizeAux_contains H)] <;> rw [normalizeAux_eval hu H le]
-    · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; rfl
-    · exact le.max
+    rw [normalizeAux_eval hv (H.imp id normalizeAux_contains) (normalizeAux_wf H wf),
+      normalizeAux_eval hu H wf, Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; rfl
   · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, rfl⟩, rfl⟩ := hu
-    rw [normalizeAux_eval hv (normalizeAux_contains H)] <;> rw [normalizeAux_eval hu H le]
-    · rw [Nat.max_assoc, Nat.add_succ, ← Nat.succ_add, ← evalPath_max, Nat.add_max_add_right]; rfl
-    · exact le.max
+    rw [normalizeAux_eval hv (H.imp id normalizeAux_contains) (normalizeAux_wf H wf),
+      normalizeAux_eval hu H wf, Nat.max_assoc, Nat.add_succ, ← Nat.succ_add,
+      ← evalPath_max, Nat.add_max_add_right]; rfl
   · rename_i u v w
     simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu
-    rw [normalizeAux_eval
-        (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) (normalizeAux_contains H)] <;>
-      rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) H le]
-    · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_max]
-    · exact le.max
+    rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩)
+        (H.imp id normalizeAux_contains) (normalizeAux_wf H wf),
+      normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) H wf,
+      Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_max]
   · rename_i u v w
     simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu
     rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hv, _, hw, rfl⟩)
-        (normalizeAux_contains H)] <;>
-      rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) H le]
-    · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_imax]
-    · exact le.max
+        (H.imp id normalizeAux_contains) (normalizeAux_wf H wf),
+      normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) H wf,
+      Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_imax]
   · rename_i u v
     simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨hv, rfl⟩, rfl⟩ := hu
-    have := @evalPath_orderedInsert ls ρ v path
+    have := Extend?.orderedInsert (cmp := Name.cmp) (p := path) (v := v)
     split <;> rename_i h <;> simp [h] at this
-    · rw [normalizeAux_eval hu NormLevel.addNode_contains_self] <;>
-        rw [NormLevel.addNode_eval, NormLevel.addConst_eval H le, Nat.max_assoc]
-      · rw [Nat.max_assoc, ← evalPath_max, this, evalPath_cons, ← evalPath_max,
+    · rw [normalizeAux_eval hu (.inr NormLevel.addNode_contains_self)
+        (NormLevel.addNode_wf (.orderedInsert h) ((wf.sortedOf H).orderedInsert h)
+          (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)),
+        NormLevel.addNode_eval, NormLevel.addConst_eval H wf, Nat.max_assoc,
+        Nat.max_assoc, ← evalPath_max, this.evalPath, evalPath_cons, ← evalPath_max,
           Nat.add_max_add_right]; congr 2
-        simp [VLevel.eval, ← evalParam_eq hv, Nat.imax]
-        cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm]
-      · refine .insert h (Nat.le_trans ?_ (Nat.le_max_right ..)) le.max
-        rw [this, evalPath_cons, ← evalPath_max]; apply evalPath_mono; grind
-    · dsimp; split
-      · rw [normalizeAux_eval hu H le]
+      simp [VLevel.eval, ← evalParam_eq hv, Lean.Nat.imax]
+      cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm]
+    · have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h
+      dsimp; split
+      · rw [normalizeAux_eval hu H wf]
         simp [evalPath]; split <;> [rename_i nz; simp]
-        have hm := (h ▸ mem_orderedInsert).2 (.inl rfl)
-        have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm
-        have := evalPath_le.1 a3 (allNZ_mono a1 nz)
+        have hm := this.mem.2 (.inl rfl)
+        obtain ⟨p1, p2, w1, a1, a2, a3, a4, z, a5, rfl⟩ := wf.of_mem hm (H.resolve_left hne)
+        refine ext_le fun n => ?_; simp [Nat.max_le, NormLevel.eval_le]; intro he
+        have := Node.eval_le.1 (evalPath_le.1 (he _ _ a4)
+          (allNZ_mono (fun _ h => (a2.mem.1 h).elim (· ▸ hm) (a1 _)) nz)) |>.2 _ a5
         simp [allNZ] at nz; specialize nz _ hm
-        simp [VLevel.eval, Nat.imax]; simp [← evalParam_eq hv]
-        revert this nz; cases evalParam .. <;> simp
-        rw [Nat.max_eq_max, Nat.max_comm (a := VLevel.eval ..), ← Nat.add_max_add_right, ← Nat.max_assoc]
-        intro h; rw [Nat.max_eq_left (b := _+1+k)]; omega
-      · rw [normalizeAux_eval hu (NormLevel.addVar_contains H)] <;> rw [NormLevel.addVar_eval H]
-        · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right, this,
-            evalPath_cons, evalPath_cons]; congr 2; split <;> simp [VLevel.eval, Nat.imax]
-          rename_i h; revert h; simp [← evalParam_eq hv]
-          cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm]
-        · exact le.max
+        simp [VLevel.eval, Lean.Nat.imax]; simp [← evalParam_eq hv, VarNode.eval] at this ⊢
+        revert this nz; cases evalParam .. <;> simp [Nat.max_eq_max]; omega
+      · rw [normalizeAux_eval hu (H.imp id NormLevel.addVar_contains)
+            (NormLevel.addVar_wf (this.mem.2 (.inl rfl)) wf),
+          NormLevel.addVar_eval (H.resolve_left hne), Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right,
+          this.evalPath, evalPath_cons, evalPath_cons]; congr 2
+        split <;> simp [VLevel.eval, Lean.Nat.imax]
+        rename_i h; revert h; simp [← evalParam_eq hv]
+        cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm]
   · cases hu
   · simp [VLevel.ofLevel] at hu
   · rename_i v; simp [VLevel.ofLevel] at hu; obtain ⟨hv, rfl⟩ := hu
-    have := @evalPath_orderedInsert ls ρ v path
+    have := Extend?.orderedInsert (cmp := Name.cmp) (p := path) (v := v)
     split <;> rename_i h <;> simp [h] at this
-    · rw [NormLevel.addNode_eval, NormLevel.addConst_eval H le, Nat.max_assoc,
-        this, evalPath_cons, ← evalPath_max]
+    · rw [NormLevel.addNode_eval, NormLevel.addConst_eval H wf, Nat.max_assoc,
+        this.evalPath, evalPath_cons, ← evalPath_max]
       simp [VLevel.eval, ← evalParam_eq hv]; congr 2; split <;> simp; omega
-    · split
-      · simp [evalPath]; split <;> [rename_i nz; simp]
-        have hm := (h ▸ mem_orderedInsert).2 (.inl rfl)
-        have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm
-        have := evalPath_le.1 a3 (allNZ_mono a1 nz)
-        simp [allNZ] at nz; specialize nz _ hm
-        simp [VLevel.eval, ← evalParam_eq hv]
-        revert this nz; cases evalParam .. <;> simp; omega
-      · rw [NormLevel.addVar_eval H, this, evalPath_cons, evalPath_cons]
-        congr 2; split <;> simp [VLevel.eval, ← evalParam_eq hv]
-
-private theorem subset_subset {xs ys : List Name} (h : subset Name.cmp xs ys) :
-    xs ⊆ ys := by
-  induction ys generalizing xs with
-  | nil => cases xs <;> simp_all [subset]
-  | cons y ys ih =>
-    cases xs with
-    | nil => simp
-    | cons x xs =>
-      simp only [subset] at h
-      split at h
-      · contradiction
-      · rename_i hxy
-        have : x = y := by simpa using hxy
-        subst y
-        exact List.cons_subset_cons _ (ih h)
-      · exact List.subset_cons_of_subset _ (ih h)
-
-private theorem leVars_dominated {xs ys : List VarNode} (h : leVars xs ys)
-    (hv : v ∈ xs) : ∃ w ∈ ys, v.var = w.var ∧ v.offset ≤ w.offset := by
-  induction xs, ys using leVars.induct with
-  | case1 ys => cases hv
-  | case2 xs => simp [leVars] at h
-  | case3 x xs y ys hcmp => simp [leVars, hcmp] at h
-  | case4 x xs y ys hcmp ih =>
-    simp only [leVars, hcmp, Bool.and_eq_true] at h
-    have hvar : x.var = y.var := by simpa using hcmp
-    rcases List.mem_cons.mp hv with rfl | hv
-    · exact ⟨y, by simp, hvar, of_decide_eq_true h.1⟩
-    · rcases ih h.2 hv with ⟨w, hw, hvar, hoff⟩
-      exact ⟨w, by simp [hw], hvar, hoff⟩
-  | case5 x xs y ys hcmp ih =>
-    simp only [leVars, hcmp] at h
-    rcases ih h hv with ⟨w, hw, hvar, hoff⟩
-    exact ⟨w, by simp [hw], hvar, hoff⟩
-
-private theorem subsumeVars_subset {xs ys : List VarNode} :
-    subsumeVars xs ys ⊆ xs := by
-  induction xs, ys using subsumeVars.induct with
-  | case1 ys => simp [subsumeVars]
-  | case2 xs h => simp [subsumeVars]
-  | case3 x xs y ys hcmp ih => simpa [subsumeVars, hcmp] using List.cons_subset_cons x ih
-  | case4 x xs y ys hcmp hoff ih =>
-    simpa [subsumeVars, hcmp, hoff] using
-      List.Subset.trans ih (List.subset_cons_self x xs)
-  | case5 x xs y ys hcmp hoff ih =>
-    simpa [subsumeVars, hcmp, hoff] using List.cons_subset_cons x ih
-  | case6 x xs y ys hcmp ih => simpa [subsumeVars, hcmp] using ih
-
-private theorem subsumeVars_dominated {xs ys : List VarNode} (hz : z ∈ xs) :
-    z ∈ subsumeVars xs ys ∨
-      ∃ y ∈ ys, z.var = y.var ∧ z.offset ≤ y.offset := by
-  induction xs, ys using subsumeVars.induct with
-  | case1 ys => cases hz
-  | case2 xs h => exact .inl (by simpa [subsumeVars])
-  | case3 x xs y ys hcmp ih =>
-    rcases List.mem_cons.mp hz with hzx | hz
-    · subst x; exact .inl (by simp [subsumeVars, hcmp])
-    · exact (ih hz).imp
-        (by simp only [subsumeVars, hcmp, List.mem_cons]; exact .inr)
-        (by rintro ⟨w, hw, hvar, hoff⟩; exact ⟨w, by simp [hw], hvar, hoff⟩)
-  | case4 x xs y ys hcmp hoff ih =>
-    have hvar : x.var = y.var := by simpa using hcmp
-    rcases List.mem_cons.mp hz with hzx | hz
-    · subst x; exact .inr ⟨y, by simp, hvar, hoff⟩
-    · rcases ih hz with hout | ⟨w, hw, hvar, hoff⟩
-      · exact .inl (by simpa [subsumeVars, hcmp, hoff] using hout)
-      · exact .inr ⟨w, by simp [hw], hvar, hoff⟩
-  | case5 x xs y ys hcmp hoff ih =>
-    rcases List.mem_cons.mp hz with hzx | hz
-    · subst x; exact .inl (by simp [subsumeVars, hcmp, hoff])
-    · rcases ih hz with hout | ⟨w, hw, hvar, hoff'⟩
-      · exact .inl (by
-          simp only [subsumeVars, hcmp, if_neg hoff, List.mem_cons]
-          exact .inr hout)
-      · exact .inr ⟨w, by simp [hw], hvar, hoff'⟩
-  | case6 x xs y ys hcmp ih =>
-    exact (ih hz).imp
-      (by simp [subsumeVars, hcmp])
-      (by rintro ⟨w, hw, hvar, hoff⟩; exact ⟨w, by simp [hw], hvar, hoff⟩)
-
-private theorem eval_insert_le {m : NormLevel} {p : List Name} {n : Node}
-    (h : evalPath ls ρ p (n.eval ls ρ) ≤ m.eval ls ρ) :
-    NormLevel.eval ls ρ (m.insert p n) ≤ m.eval ls ρ := by
-  rw [NormLevel.eval_le]
-  intro a b hab
-  simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert] at hab
-  split at hab
-  · rename_i heq
-    have : p = a := by simpa using heq
-    subst a
-    cases hab
-    exact h
-  · exact NormLevel.eval_le.1 (Nat.le_refl _) _ _ hab
-
-private theorem eval_le_insert {m : NormLevel} {p : List Name} {old new : Node}
-    (hget : m.get? p = some old)
-    (h : evalPath ls ρ p (old.eval ls ρ) ≤ NormLevel.eval ls ρ (m.insert p new)) :
-    m.eval ls ρ ≤ NormLevel.eval ls ρ (m.insert p new) := by
-  rw [NormLevel.eval_le]
-  intro a b hab
-  by_cases hpa : p = a
-  · subst a
-    cases hget.symm.trans hab
-    exact h
-  · apply NormLevel.eval_le.1 (Nat.le_refl _) a b
-    simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
-    have hcmp : compare p a ≠ .eq := by simpa using hpa
-    rw [if_neg hcmp]
-    exact hab
-
-private theorem eval_insert_eq {m : NormLevel} {p : List Name} {old new : Node}
-    (hget : m.get? p = some old)
-    (hnew : evalPath ls ρ p (new.eval ls ρ) ≤ evalPath ls ρ p (old.eval ls ρ))
-    (hold : evalPath ls ρ p (old.eval ls ρ) ≤ NormLevel.eval ls ρ (m.insert p new)) :
-    NormLevel.eval ls ρ (m.insert p new) = m.eval ls ρ := by
-  apply Nat.le_antisymm
-  · apply eval_insert_le
-    exact Nat.le_trans hnew (NormLevel.eval_le.1 (Nat.le_refl _) p old hget)
-  · exact eval_le_insert hget hold
-
-private theorem node_eval_mono {a b : Node} (hc : a.const ≤ b.const)
-    (hv : a.var ⊆ b.var) : a.eval ls ρ ≤ b.eval ls ρ := by
-  apply Node.eval_le.2
-  refine ⟨Nat.le_trans hc (Node.eval_le.1 (Nat.le_refl _) |>.1), ?_⟩
-  intro v hv'
-  exact Node.eval_le.1 (Nat.le_refl _) |>.2 v (hv hv')
-
-private theorem eval_replace_eq {m : NormLevel} {p : List Name} {old new : Node}
-    (hnew : evalPath ls ρ p (new.eval ls ρ) ≤ evalPath ls ρ p (old.eval ls ρ))
-    (hold : evalPath ls ρ p (old.eval ls ρ) ≤ NormLevel.eval ls ρ (m.insert p new)) :
-    NormLevel.eval ls ρ (m.insert p new) = NormLevel.eval ls ρ (m.insert p old) := by
-  apply Nat.le_antisymm
-  · rw [NormLevel.eval_le]
-    intro a b hab
-    simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert] at hab
-    split at hab
-    · rename_i heq
-      have : p = a := by simpa using heq
-      subst a
-      cases hab
-      exact Nat.le_trans hnew
-        (NormLevel.eval_le.1 (Nat.le_refl _) p old (by
-          simpa only [Std.TreeMap.get?_eq_getElem?] using
-            (Std.TreeMap.getElem?_insert_self (t := m) (k := p) (v := old))))
-    · rename_i hneq
-      apply NormLevel.eval_le.1 (Nat.le_refl _) a b
-      simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
-      rw [if_neg hneq]
-      exact hab
-  · rw [NormLevel.eval_le]
-    intro a b hab
-    simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert] at hab
-    split at hab
-    · rename_i heq
-      have : p = a := by simpa using heq
-      subst a
-      cases hab
-      exact hold
-    · rename_i hneq
-      apply NormLevel.eval_le.1 (Nat.le_refl _) a b
-      simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
-      rw [if_neg hneq]
-      exact hab
-
-private theorem subsumptionStep_eval_le (n₁ n₂ : Node) (p₁ p₂ : List Name) :
-    (n₁.subsumptionStep p₁ p₂ n₂).eval ls ρ ≤ n₁.eval ls ρ := by
-  unfold Node.subsumptionStep
-  split
-  · exact Nat.le_refl _
-  · dsimp only
-    split <;> split
-    all_goals apply node_eval_mono
-    all_goals simp [subsumeVars_subset]
-
-private theorem insert_self_bound {m : NormLevel} {p : List Name} {n : Node} :
-    evalPath ls ρ p (n.eval ls ρ) ≤ NormLevel.eval ls ρ (m.insert p n) := by
-  apply NormLevel.eval_le.1 (Nat.le_refl _) p n
-  simpa only [Std.TreeMap.get?_eq_getElem?] using
-    (Std.TreeMap.getElem?_insert_self (t := m) (k := p) (v := n))
-
-private theorem insert_other_bound {m : NormLevel} {p q : List Name} {new n : Node}
-    (hpq : p ≠ q) (hget : m.get? q = some n) :
-    evalPath ls ρ q (n.eval ls ρ) ≤ NormLevel.eval ls ρ (m.insert p new) := by
-  apply NormLevel.eval_le.1 (Nat.le_refl _) q n
-  simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
-  have hcmp : compare p q ≠ .eq := by simpa using hpq
-  rw [if_neg hcmp]
-  exact hget
-
-private theorem const_le_activeVar_eval {v : VarNode} (hv : v.var ∈ p)
-    (hnz : allNZ ls ρ p) (hc : c ≤ v.offset + 1) : c ≤ v.eval ls ρ := by
-  simp [allNZ] at hnz
-  simp only [VarNode.eval]
-  specialize hnz _ hv
-  omega
-
-private theorem varNode_eval_mono {v w : VarNode} (hvar : v.var = w.var)
-    (hoff : v.offset ≤ w.offset) : v.eval ls ρ ≤ w.eval ls ρ := by
-  simp only [VarNode.eval, hvar]
-  omega
-
-private theorem vars_le_self {m : NormLevel} {p : List Name} {old new : Node}
-    (hvars : old.var ⊆ new.var) (hnz : allNZ ls ρ p) :
-    ∀ v ∈ old.var, v.eval ls ρ ≤ NormLevel.eval ls ρ (m.insert p new) := by
-  have hnode := evalPath_le.1 (insert_self_bound (ls := ls) (ρ := ρ)
-    (m := m) (p := p) (n := new)) hnz
-  exact fun v hv => Node.eval_le.1 hnode |>.2 v (hvars hv)
-
-private theorem vars_le_after_subsume {m : NormLevel} {p₁ p₂ : List Name}
-    {old new n₂ : Node} (hvars : new.var = subsumeVars old.var n₂.var)
-    (hsub : subset Name.cmp p₂ p₁) (hlen : p₁.length ≠ p₂.length)
-    (hget : m.get? p₂ = some n₂) (hnz : allNZ ls ρ p₁) :
-    ∀ v ∈ old.var, v.eval ls ρ ≤ NormLevel.eval ls ρ (m.insert p₁ new) := by
-  intro v hv
-  rcases subsumeVars_dominated hv with hkeep | ⟨w, hw, hvar, hoff⟩
-  · have hnode := evalPath_le.1 (insert_self_bound (ls := ls) (ρ := ρ)
-      (m := m) (p := p₁) (n := new)) hnz
-    exact Node.eval_le.1 hnode |>.2 v (by rw [hvars]; exact hkeep)
-  · have hpne : p₁ ≠ p₂ := fun h => hlen (congrArg List.length h)
-    have hnz₂ := allNZ_mono (subset_subset hsub) hnz
-    have hnode := evalPath_le.1 (insert_other_bound (ls := ls) (ρ := ρ)
-      (m := m) (p := p₁) (q := p₂) (new := new) hpne hget) hnz₂
-    exact Nat.le_trans (varNode_eval_mono hvar hoff)
-      (Node.eval_le.1 hnode |>.2 w hw)
-
-private theorem const_le_of_subsumed {m : NormLevel} {p₁ p₂ : List Name}
-    {old new n₂ : Node} (hdom : old.constIsSubsumedBy p₁ p₂ n₂)
-    (hsub : subset Name.cmp p₂ p₁) (hget : m.get? p₂ = some n₂)
-    (hvars : ∀ v ∈ old.var,
-      v.eval ls ρ ≤ NormLevel.eval ls ρ (m.insert p₁ new))
-    (hnz : allNZ ls ρ p₁) :
-    old.const ≤ NormLevel.eval ls ρ (m.insert p₁ new) := by
-  rcases hdom with ⟨hlen, hc⟩ | ⟨hne, v, hv, hvp, hc⟩ |
-      ⟨hlen, hc, v, hv, hvp⟩
-  · have hpne : p₁ ≠ p₂ := fun h => hlen (congrArg List.length h)
-    have hnz₂ := allNZ_mono (subset_subset hsub) hnz
-    have hnode := evalPath_le.1 (insert_other_bound (ls := ls) (ρ := ρ)
-      (m := m) (p := p₁) (q := p₂) (new := new) hpne hget) hnz₂
-    exact Nat.le_trans hc (Node.eval_le.1 hnode |>.1)
-  · exact Nat.le_trans (const_le_activeVar_eval hvp hnz hc) (hvars v hv)
-  · have hpne : p₁ ≠ p₂ := fun h => hlen (congrArg List.length h)
-    have hnz₂ := allNZ_mono (subset_subset hsub) hnz
-    have hnode := evalPath_le.1 (insert_other_bound (ls := ls) (ρ := ρ)
-      (m := m) (p := p₁) (q := p₂) (new := new) hpne hget) hnz₂
-    have hcv : old.const ≤ v.offset + 1 := by omega
-    exact Nat.le_trans (const_le_activeVar_eval hvp hnz₂ hcv)
-      (Node.eval_le.1 hnode |>.2 v hv)
-
-private theorem subsumptionStep_bound {m : NormLevel} {p₁ p₂ : List Name}
-    {n₁ n₂ : Node} (hget : m.get? p₂ = some n₂) :
-    evalPath ls ρ p₁ (n₁.eval ls ρ) ≤
-      NormLevel.eval ls ρ (m.insert p₁ (n₁.subsumptionStep p₁ p₂ n₂)) := by
-  unfold Node.subsumptionStep
-  split
-  · exact insert_self_bound
-  · rename_i hsub'
-    simp at hsub'
-    change subset Name.cmp p₂ p₁ at hsub'
-    have hsub := hsub'
-    dsimp only
+    have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h
     split
-    · rename_i hvars'
-      split
-      · exact insert_self_bound
-      · rename_i hconst
-        have hdom : n₁.constIsSubsumedBy p₁ p₂ n₂ := by
-          by_cases hdom : n₁.constIsSubsumedBy p₁ p₂ n₂
-          · exact hdom
-          · exact False.elim (hconst (.inr hdom))
-        apply evalPath_le.2
-        intro hnz
-        apply Node.eval_le.2
-        have hvars := vars_le_self (ls := ls) (ρ := ρ)
-          (m := m) (p := p₁) (old := n₁) (new := { n₁ with const := 0 })
-          (by simp) hnz
-        exact ⟨const_le_of_subsumed (ls := ls) (ρ := ρ)
-          hdom hsub hget hvars hnz, hvars⟩
-    · rename_i hvars'
-      simp at hvars'
-      split
-      · rename_i hconst
-        apply evalPath_le.2
-        intro hnz
-        apply Node.eval_le.2
-        have hvars := vars_le_after_subsume (ls := ls) (ρ := ρ)
-          (m := m) (p₁ := p₁) (p₂ := p₂) (old := n₁)
-          (new := { n₁ with var := subsumeVars n₁.var n₂.var }) (n₂ := n₂)
-          (by simp) hsub hvars'.1 hget hnz
-        have hnode := evalPath_le.1 (insert_self_bound (ls := ls) (ρ := ρ)
-          (m := m) (p := p₁) (n := { n₁ with var := subsumeVars n₁.var n₂.var })) hnz
-        exact ⟨Node.eval_le.1 hnode |>.1, hvars⟩
-      · rename_i hconst
-        have hdom : n₁.constIsSubsumedBy p₁ p₂ n₂ := by
-          by_cases hdom : n₁.constIsSubsumedBy p₁ p₂ n₂
-          · exact hdom
-          · exact False.elim (hconst (.inr hdom))
-        apply evalPath_le.2
-        intro hnz
-        apply Node.eval_le.2
-        have hvars := vars_le_after_subsume (ls := ls) (ρ := ρ)
-          (m := m) (p₁ := p₁) (p₂ := p₂) (old := n₁)
-          (new := { n₁ with const := 0, var := subsumeVars n₁.var n₂.var })
-          (n₂ := n₂) (by simp) hsub hvars'.1 hget hnz
-        exact ⟨const_le_of_subsumed (ls := ls) (ρ := ρ)
-          hdom hsub hget hvars hnz, hvars⟩
-
-private theorem subsumptionStep_eval {m : NormLevel} {p₁ p₂ : List Name}
-    {n₁ n₂ : Node} (hget : m.get? p₂ = some n₂) :
-    NormLevel.eval ls ρ (m.insert p₁ (n₁.subsumptionStep p₁ p₂ n₂)) =
-      NormLevel.eval ls ρ (m.insert p₁ n₁) := by
-  apply eval_replace_eq
-  · exact evalPath_mono (subsumptionStep_eval_le n₁ n₂ p₁ p₂)
-  · exact subsumptionStep_bound hget
-
-private theorem subsumptionList_eval {m : NormLevel} {p₁ : List Name}
-    {entries : List (List Name × Node)}
-    (hentries : ∀ x ∈ entries, m.get? x.1 = some x.2) (n₁ : Node) :
-    NormLevel.eval ls ρ
-      (m.insert p₁ (entries.foldl (init := n₁)
-        fun n₁ x => n₁.subsumptionStep p₁ x.1 x.2)) =
-      NormLevel.eval ls ρ (m.insert p₁ n₁) := by
-  induction entries generalizing n₁ with
-  | nil => rfl
-  | cons x entries ih =>
-    rcases x with ⟨p₂, n₂⟩
-    simp only [List.foldl_cons]
-    calc
-      NormLevel.eval ls ρ
-          (m.insert p₁ (entries.foldl (init := n₁.subsumptionStep p₁ p₂ n₂)
-            fun n₁ x => n₁.subsumptionStep p₁ x.1 x.2)) =
-        NormLevel.eval ls ρ (m.insert p₁ (n₁.subsumptionStep p₁ p₂ n₂)) :=
-          ih (fun x hx => hentries x (List.Mem.tail _ hx)) _
-      _ = NormLevel.eval ls ρ (m.insert p₁ n₁) :=
-        subsumptionStep_eval (hentries _ (.head _))
-
-private theorem subsumptionFold_eval {m : NormLevel} {p₁ : List Name} (n₁ : Node) :
-    NormLevel.eval ls ρ
-      (m.insert p₁ (m.foldl (init := n₁)
-        fun n₁ p₂ n₂ => n₁.subsumptionStep p₁ p₂ n₂)) =
-      NormLevel.eval ls ρ (m.insert p₁ n₁) := by
-  rw [Std.TreeMap.foldl_eq_foldl_toList]
-  apply subsumptionList_eval
-  intro x hx
-  exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hx
-
-private theorem subsumptionOuterList_eval {entries : List (List Name × Node)}
-    {m : NormLevel}
-    (hentries : ∀ x ∈ entries, m.get? x.1 = some x.2)
-    (hdistinct : entries.Pairwise fun a b => ¬compare a.1 b.1 = .eq) :
-    NormLevel.eval ls ρ
-      (entries.foldl (init := m) fun m x =>
-        m.insert x.1 (m.foldl (init := x.2)
-          fun n₁ p₂ n₂ => n₁.subsumptionStep x.1 p₂ n₂)) =
-      NormLevel.eval ls ρ m := by
-  induction entries generalizing m with
-  | nil => rfl
-  | cons x entries ih =>
-    rcases x with ⟨p₁, n₁⟩
-    simp only [List.pairwise_cons] at hdistinct
-    simp only [List.foldl_cons]
-    let n₁' := m.foldl (init := n₁)
-      fun n₁ p₂ n₂ => n₁.subsumptionStep p₁ p₂ n₂
-    let m' := m.insert p₁ n₁'
-    have hentries' : ∀ x ∈ entries, m'.get? x.1 = some x.2 := by
-      intro x hx
-      simp only [m', Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
-      rw [if_neg (hdistinct.1 x hx)]
-      exact hentries x (.tail _ hx)
-    have hstep : NormLevel.eval ls ρ m' = NormLevel.eval ls ρ m := by
-      calc
-        NormLevel.eval ls ρ m' = NormLevel.eval ls ρ (m.insert p₁ n₁) :=
-          subsumptionFold_eval n₁
-        _ = NormLevel.eval ls ρ m := eval_insert_eq
-          (hentries _ (.head _)) (Nat.le_refl _) insert_self_bound
-    exact (ih hentries' hdistinct.2).trans hstep
-
-theorem NormLevel.subsumption_eval {s : NormLevel} :
+    · simp [evalPath]; split <;> [rename_i nz; simp]
+      have hm := this.mem.2 (.inl rfl)
+      obtain ⟨p1, p2, w1, a1, a2, a3, a4, z, a5, rfl⟩ := wf.of_mem hm (H.resolve_left hne)
+      refine ext_le fun n => ?_; simp [Nat.max_le, NormLevel.eval_le]; intro he
+      have := Node.eval_le.1 (evalPath_le.1 (he _ _ a4)
+        (allNZ_mono (fun _ h => (a2.mem.1 h).elim (· ▸ hm) (a1 _)) nz)) |>.2 _ a5
+      simp [allNZ] at nz; specialize nz _ hm
+      simp [VLevel.eval]; simp [← evalParam_eq hv, VarNode.eval] at this ⊢
+      revert this nz; cases evalParam .. <;> simp; omega
+    · rw [NormLevel.addVar_eval (H.resolve_left hne), this.evalPath, evalPath_cons,
+        evalPath_cons]
+      congr 2; split <;> simp [VLevel.eval, ← evalParam_eq hv]
+
+theorem subset_length (H : subset cmp l₁ l₂) : l₁.length ≤ l₂.length := by
+  induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih
+  cases l₁ with | nil => simp | cons x l₁
+  simp only [subset] at H; split at H
+  · cases H
+  · have := ih H; simp only [List.length_cons]; omega
+  · have := ih H; simp only [List.length_cons] at this ⊢; omega
+
+theorem subset_mem [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp]
+    (H : subset cmp l₁ l₂) (h : a ∈ l₁) : a ∈ l₂ := by
+  induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih
+  cases l₁ with| nil => cases h | cons x l₁
+  simp only [subset] at H; split at H
+  · cases H
+  · rename_i h'; rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at h'
+    cases eq_of_beq h'
+    rcases List.mem_cons.1 h with rfl | h
+    · exact .head _
+    · exact .tail _ (ih H h)
+  · exact .tail _ (ih H h)
+
+theorem subset_eq [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp]
+    (H : subset cmp l₁ l₂) (hl : l₁.length = l₂.length) : l₁ = l₂ := by
+  induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih
+  cases l₁ with | nil => cases hl | cons x l₁
+  simp only [subset] at H; simp only [List.length_cons] at hl
+  split at H
+  · cases H
+  · rename_i h'; rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at h'
+    cases eq_of_beq h'; rw [ih H (by omega)]
+  · exact absurd (subset_length H) (by simp only [List.length_cons]; omega)
+
+/-- On sorted lists, `subset` decides inclusion. -/
+theorem subset_of_sorted (h₁ : Sorted l₁) (h₂ : Sorted l₂) (h : ∀ x ∈ l₁, x ∈ l₂) :
+    subset compare l₁ l₂ := by
+  induction l₂ generalizing l₁ with
+  | nil => cases l₁ with | nil => rfl | cons x l₁ => cases h x (.head _)
+  | cons y l₂ ih
+  cases l₁ with | nil => rfl | cons x l₁
+  simp only [subset]
+  have hxy := h x (.head _)
+  split <;> rename_i hc
+  · -- `x < y` is impossible: `x` is in `y :: l₂`, whose elements are all `≥ y`
+    obtain rfl | hx := List.mem_cons.1 hxy
+    · rw [Std.ReflOrd.compare_self] at hc; cases hc
+    · exact absurd (h₂.head _ hx) (by rw [Std.OrientedCmp.gt_of_lt hc]; simp)
+  · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at hc
+    cases eq_of_beq hc
+    refine ih h₁.of_cons h₂.of_cons fun z hz => ?_
+    obtain rfl | hz' := List.mem_cons.1 (h z (.tail _ hz))
+    · exact absurd (h₁.head _ hz) (by rw [Std.ReflOrd.compare_self]; simp)
+    · exact hz'
+  · refine ih h₁ h₂.of_cons fun z hz => ?_
+    obtain rfl | hz' := List.mem_cons.1 (h z hz)
+    · obtain rfl | hz := List.mem_cons.1 hz
+      · exact absurd hc (by rw [Std.ReflOrd.compare_self]; simp)
+      · exact absurd (h₁.head _ hz) (by
+          rw [Std.OrientedCmp.gt_of_lt (Std.OrientedCmp.lt_of_gt hc)]; simp)
+    · exact hz'
+
+theorem subsumeVars_subset (h : x ∈ subsumeVars vs₁ vs₂) : x ∈ vs₁ := by
+  induction vs₁ generalizing vs₂ with | nil => simp_all [subsumeVars] | cons a vs₁ ih
+  induction vs₂ with | nil => simp_all [subsumeVars] | cons b vs₂ ih₂
+  simp only [subsumeVars] at h; split at h
+  · obtain rfl | h := List.mem_cons.1 h
+    · exact .head _
+    · exact .tail _ (ih h)
+  · split at h <;> [exact .tail _ (ih h); skip]
+    obtain rfl | h := List.mem_cons.1 h
+    · exact .head _
+    · exact .tail _ (ih h)
+  · exact ih₂ h
+
+theorem subsumeVars_dominated (h₁ : x ∈ vs₁) (h₂ : x ∉ subsumeVars vs₁ vs₂) :
+    ∃ y ∈ vs₂, y.var = x.var ∧ x.offset ≤ y.offset := by
+  induction vs₁ generalizing vs₂ with | nil => cases h₁ | cons a vs₁ ih
+  induction vs₂ with | nil => exact absurd h₁ (by simpa [subsumeVars] using h₂) | cons b vs₂ ih₂
+  simp only [subsumeVars] at h₂; split at h₂
+  · obtain rfl | h₁ := List.mem_cons.1 h₁
+    · cases h₂ (.head _)
+    · have ⟨y, hy, e, le⟩ := ih h₁ fun h => h₂ (.tail _ h)
+      exact ⟨y, hy, e, le⟩
+  · rename_i heq; split at h₂
+    · obtain rfl | h₁ :=  List.mem_cons.1 h₁
+      · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at heq
+        exact ⟨b, .head _, (eq_of_beq heq).symm, ‹_›⟩
+      · have ⟨y, hy, e, le⟩ := ih h₁ h₂
+        exact ⟨y, .tail _ hy, e, le⟩
+    · obtain rfl | h₁ :=  List.mem_cons.1 h₁
+      · cases h₂ (.head _)
+      · have ⟨y, hy, e, le⟩ := ih h₁ fun h => h₂ (.tail _ h)
+        exact ⟨y, .tail _ hy, e, le⟩
+  · have ⟨y, hy, e, le⟩ := ih₂ h₂
+    exact ⟨y, .tail _ hy, e, le⟩
+
+theorem le_foldl_max {vs : List VarNode}
+    (h : c ≤ vs.foldl (·.max ·.offset) n + 1) : c ≤ n + 1 ∨ ∃ y ∈ vs, c ≤ y.offset + 1 := by
+  induction vs generalizing n with | nil => exact .inl h | cons x vs ih
+  obtain h | ⟨y, hy, h⟩ := ih h
+  · refine (Nat.le_total x.offset n).imp (fun h' => ?_) (fun h' => ⟨x, .head _, ?_⟩)
+    · simp [Nat.max_eq_left h'] at h; omega
+    · simp [Nat.max_eq_right h'] at h; omega
+  · exact .inr ⟨y, .tail _ hy, h⟩
+
+theorem Node.const_le_eval {l : Node} : l.const ≤ Node.eval ls ρ l :=
+  (Node.eval_le.1 (Nat.le_refl _)).1
+
+theorem Node.var_le_eval {l : Node} (h : x ∈ l.var) :
+    VarNode.eval ls ρ x ≤ Node.eval ls ρ l :=
+  (Node.eval_le.1 (Nat.le_refl _)).2 _ h
+
+theorem Node.eval_empty {l : Node} (H : l.isEmpty) : Node.eval ls ρ l = 0 := by
+  simp [Node.isEmpty] at H; simp [eval, H.1, H.2]
+
+theorem NormLevel.eval_filter {m : NormLevel} :
+    NormLevel.eval ls ρ (m.filter fun _ n => !n.isEmpty) = m.eval ls ρ := by
+  refine ext_le fun x => ?_
+  simp only [eval_le, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_filter]
+  refine ⟨fun H a b h => ?_, fun H a b h => ?_⟩
+  · by_cases he : b.isEmpty
+    · simp [evalPath_le, Node.eval_empty he]
+    · exact H a b (by simp [h, he])
+  · exact H _ _ (Option.eq_some_of_pfilter_eq_some h)
+
+theorem subsumeVars_eval (H : ∀ v ∈ vs₂, VarNode.eval ls ρ v ≤ n) :
+    (∀ v ∈ subsumeVars vs₁ vs₂, VarNode.eval ls ρ v ≤ n) ↔
+    ∀ v ∈ vs₁, VarNode.eval ls ρ v ≤ n := by
+  refine ⟨fun h v hv => ?_, fun h v hv => h _ (subsumeVars_subset hv)⟩
+  by_cases hs : v ∈ subsumeVars vs₁ vs₂ <;> [exact h _ hs; skip]
+  have ⟨y, hy, e, le⟩ := subsumeVars_dominated hv hs
+  exact Nat.le_trans (by simp [VarNode.eval, e]; omega) (H _ hy)
+
+theorem Node.subsumeBy_const_eq {same : Bool} {n₁ n₂ : Node} :
+    (n₁.subsumeBy same n₂).const =
+    if n₁.const = 0 ||
+      (same || n₁.const > n₂.const) &&
+      (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1)
+    then n₁.const else 0 := by
+  simp only [Node.subsumeBy]; split <;> split <;> rfl
+
+theorem Node.subsumeBy_var_eq {same : Bool} {n₁ n₂ : Node} :
+    (n₁.subsumeBy same n₂).var =
+    if same || n₂.var.isEmpty then n₁.var else subsumeVars n₁.var n₂.var := by
+  simp only [Node.subsumeBy]; split <;> split <;> simp
+
+theorem Node.subsumeBy_var_subset {same : Bool}
+    (h : x ∈ (Node.subsumeBy same n₁ n₂).var) : x ∈ n₁.var := by
+  rw [Node.subsumeBy_var_eq] at h; split at h <;> [exact h; exact subsumeVars_subset h]
+
+theorem Node.subsumeBy_const_cases {same : Bool} (n₁ n₂ : Node) :
+    (n₁.subsumeBy same n₂).const = n₁.const ∨ (n₁.subsumeBy same n₂).const = 0 := by
+  rw [Node.subsumeBy_const_eq]; split <;> [exact .inl rfl; exact .inr rfl]
+
+theorem Node.subsumeBy_eval_le {same : Bool} :
+    Node.eval ls ρ (n₁.subsumeBy same n₂) ≤ Node.eval ls ρ n₁ := by
+  refine Node.eval_le.2 ⟨?_, fun v h => Node.var_le_eval (Node.subsumeBy_var_subset h)⟩
+  obtain h | h := Node.subsumeBy_const_cases (same := same) n₁ n₂
+  · exact h ▸ Node.const_le_eval
+  · simp [h]
+
+/-- If `subsumeBy` dropped the constant, the drop was justified: the constant is dominated
+by the constant of `n₂` (only possible when the two keys differ), or by a variable of `n₂`. -/
+theorem Node.subsumeBy_const_drop {same : Bool}
+    (h : (Node.subsumeBy same n₁ n₂).const ≠ n₁.const) :
+    same = false ∧ n₁.const ≤ n₂.const ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1 := by
+  rw [Node.subsumeBy_const_eq] at h
+  split at h <;> [cases h rfl; rename_i hc]
+  rw [Bool.or_eq_true, not_or] at hc
+  obtain ⟨-, hc⟩ := hc
+  rw [Bool.and_eq_true, Decidable.not_and_iff_not_or_not] at hc
+  obtain hc | hc := hc <;> rw [Bool.or_eq_true, not_or] at hc <;> obtain ⟨h1, h2⟩ := hc
+  · exact .inl ⟨by simpa using h1, by simpa [Nat.not_lt] using h2⟩
+  · have hne : n₂.var ≠ [] := fun e => h1 (by simp [e])
+    have h2 : n₁.const ≤ n₂.var.foldl (·.max ·.offset) 0 + 1 := by
+      simpa [Nat.not_lt] using h2
+    obtain h | h := le_foldl_max (c := n₁.const) (n := 0) h2
+    · obtain ⟨y, hy⟩ := List.exists_mem_of_ne_nil _ hne
+      exact .inr ⟨y, hy, by omega⟩
+    · exact .inr h
+
+/-- The domination step is exact against a node bounded by `m`: everything `subsumeBy`
+drops from `n₁` is dominated by a sublevel of `n₂`, and `n₂` evaluates to at most `m`.
+Domination of the constant by a variable needs that variable to evaluate to at least its
+offset plus one, which is why the condition set must be all-nonzero (`hnz`). -/
+theorem Node.subsumeBy_eval_iff {same : Bool} {n₁ n₂ : Node} {m : Nat}
+    (hnz : ∀ v ∈ n₂.var, 0 < evalParam ls ρ v.var) (h₂ : Node.eval ls ρ n₂ ≤ m) :
+    Node.eval ls ρ (n₁.subsumeBy same n₂) ≤ m ↔ Node.eval ls ρ n₁ ≤ m := by
+  have hvar₂ v (hv : v ∈ n₂.var) : VarNode.eval ls ρ v ≤ m :=
+    Nat.le_trans (Node.var_le_eval hv) h₂
+  refine ⟨fun h => ?_, fun h => Nat.le_trans Node.subsumeBy_eval_le h⟩
+  rw [Node.eval_le] at h ⊢
+  refine ⟨?_, fun x hx => ?_⟩
+  · by_cases hc : (n₁.subsumeBy same n₂).const = n₁.const
+    · exact hc ▸ h.1
+    obtain ⟨-, hle⟩ | ⟨y, hy, hle⟩ := Node.subsumeBy_const_drop hc
+    · exact Nat.le_trans hle (Nat.le_trans Node.const_le_eval h₂)
+    · refine Nat.le_trans ?_ (hvar₂ _ hy)
+      have := hnz _ hy; simp only [VarNode.eval]; omega
+  · rw [Node.subsumeBy_var_eq] at h
+    split at h
+    · exact h.2 _ hx
+    · exact (subsumeVars_eval hvar₂).1 h.2 _ hx
+
+theorem Node.subsume_const_eq : (Node.subsume p₁ n₁ p₂ n₂).const =
+    if !subset compare p₂ p₁ ||
+      (n₁.const = 0 ||
+      (p₁.length == p₂.length || n₁.const > n₂.const) &&
+      (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1))
+    then n₁.const else 0 := by
+  simp only [Node.subsume]
+  cases hs : subset compare p₂ p₁ <;>
+    simp only [reduceIte, Bool.not_true, Bool.not_false, Bool.false_or, Bool.true_or]
+  · rfl
+  · exact subsumeBy_const_eq
+
+theorem Node.subsume_var_eq : (Node.subsume p₁ n₁ p₂ n₂).var =
+    if !subset compare p₂ p₁ || (p₁.length == p₂.length || n₂.var.isEmpty)
+    then n₁.var else subsumeVars n₁.var n₂.var := by
+  simp only [Node.subsume]
+  cases hs : subset compare p₂ p₁ <;>
+    simp only [reduceIte, Bool.not_true, Bool.not_false, Bool.false_or, Bool.true_or]
+  · rfl
+  · exact subsumeBy_var_eq
+
+theorem Node.subsume_var_subset (h : x ∈ (Node.subsume p₁ n₁ p₂ n₂).var) : x ∈ n₁.var := by
+  rw [Node.subsume] at h; split at h <;> [exact subsumeBy_var_subset h; exact h]
+
+theorem Node.subsume_const_cases (p₁ n₁ p₂ n₂) :
+    (Node.subsume p₁ n₁ p₂ n₂).const = n₁.const ∨ (Node.subsume p₁ n₁ p₂ n₂).const = 0 := by
+  rw [Node.subsume]; split <;> [exact subsumeBy_const_cases ..; exact .inl rfl]
+
+theorem Node.subsume_eval_le :
+    Node.eval ls ρ (Node.subsume p₁ n₁ p₂ n₂) ≤ Node.eval ls ρ n₁ := by
+  rw [Node.subsume]; split <;> [exact subsumeBy_eval_le; exact Nat.le_refl _]
+
+/-- If `subsume` dropped the constant, the drop was justified: the constant is dominated
+by the constant of `n₂` at a strictly smaller key, or by a variable of `n₂`. -/
+theorem Node.subsume_const_drop (h : (Node.subsume p₁ n₁ p₂ n₂).const ≠ n₁.const) :
+    subset compare p₂ p₁ ∧
+    (p₁.length ≠ p₂.length ∧ n₁.const ≤ n₂.const ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1) := by
+  rw [Node.subsume] at h
+  split at h <;> [skip; cases h rfl]
+  refine ⟨‹_›, (subsumeBy_const_drop h).imp_left fun ⟨he, hc⟩ => ⟨fun e => ?_, hc⟩⟩
+  simp [e] at he
+
+/-- If `subsume` changed the variable list, the change was `subsumeVars` against the
+variables of `n₂` at a strictly smaller key. -/
+theorem Node.subsume_var_cases (p₁ n₁ p₂ n₂) :
+    (Node.subsume p₁ n₁ p₂ n₂).var = n₁.var ∨
+    (subset compare p₂ p₁ ∧ p₁.length ≠ p₂.length ∧
+     (Node.subsume p₁ n₁ p₂ n₂).var = subsumeVars n₁.var n₂.var) := by
+  rw [Node.subsume_var_eq]; split
+  · exact .inl rfl
+  · rename_i hc
+    rw [Bool.or_eq_true, Bool.or_eq_true, not_or, not_or] at hc
+    obtain ⟨hs, hlen, -⟩ := hc
+    have hsub : subset compare p₂ p₁ := by revert hs; cases subset compare p₂ p₁ <;> simp
+    exact .inr ⟨hsub, fun e => hlen (by simp [e]), rfl⟩
+
+theorem NormLevel.minimize_var_subset {acc : NormLevel}
+    (h : x ∈ (acc.minimize p₁ n₁).var) : x ∈ n₁.var := by
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h
+  generalize acc.toList = l at h
+  induction l generalizing n₁ with | nil => exact h | cons a l ih
+  exact Node.subsume_var_subset (ih h)
+
+theorem NormLevel.minimize_eval_le {acc : NormLevel} :
+    Node.eval ls ρ (acc.minimize p₁ n₁) ≤ n₁.eval ls ρ := by
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList]
+  generalize acc.toList = l
+  induction l generalizing n₁ with | nil => exact Nat.le_refl _ | cons a l ih
+  exact Nat.le_trans (ih (n₁ := Node.subsume p₁ n₁ a.1 a.2)) Node.subsume_eval_le
+
+/-- Minimizing a node against the rest of the map preserves its contribution to the total,
+assuming every other entry's contribution is already bounded by `m`. -/
+theorem NormLevel.minimize_eval_iff {acc : NormLevel} {p₁ : List Name} {n₁ : Node} {m : Nat}
+    (wfa : ∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p)
+    (h₁ : acc.get? p₁ = some n₁)
+    (hacc : ∀ p n, p ≠ p₁ → acc.get? p = some n → evalPath ls ρ p (Node.eval ls ρ n) ≤ m)
+    (nz : allNZ ls ρ p₁) :
+    Node.eval ls ρ (acc.minimize p₁ n₁) ≤ m ↔ Node.eval ls ρ n₁ ≤ m := by
+  have wf₁ := wfa _ _ h₁
+  have evalq p₂ n₂ (hne : p₂ ≠ p₁) (h₂ : acc.get? p₂ = some n₂) (hsub : subset compare p₂ p₁) :
+      Node.eval ls ρ n₂ ≤ m := by
+    have := hacc _ _ hne h₂
+    rw [evalPath_le] at this
+    exact this (allNZ_mono (fun _ h => subset_mem hsub h) nz)
+  -- a variable dominated at a different key of the map is bounded by `m`
+  have domle (x : VarNode) : (∃ p₂ n₂ y, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧
+      subset compare p₂ p₁ ∧ y ∈ n₂.var ∧ y.var = x.var ∧ x.offset ≤ y.offset) →
+      VarNode.eval ls ρ x ≤ m := fun ⟨p₂, n₂, y, hne, h₂, hsub, hy, e, le⟩ => by
+    refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy) (evalq _ _ hne h₂ hsub))
+    simp only [VarNode.eval, ← e]; omega
+  refine ⟨fun hf => ?_, fun h => Nat.le_trans minimize_eval_le h⟩
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at hf
+  have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  generalize acc.toList = l at hf hmem
+  -- fold invariant: vars of the current node come from `n₁`; the constant is intact or
+  -- justifiably dropped; every original variable is dominated by a current one or elsewhere
+  suffices ∀ n1, (∀ x ∈ n1.var, x ∈ n₁.var) →
+      (n1.const = n₁.const ∨ (n1.const = 0 ∧
+        ((∃ y ∈ n₁.var, n₁.const ≤ y.offset + 1) ∨
+         ∃ p₂ n₂, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧ subset compare p₂ p₁ ∧
+           n₁.const ≤ Node.eval ls ρ n₂))) →
+      (∀ x ∈ n₁.var, (∃ y ∈ n1.var, y.var = x.var ∧ x.offset ≤ y.offset) ∨
+        ∃ p₂ n₂ y, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧ subset compare p₂ p₁ ∧
+          y ∈ n₂.var ∧ y.var = x.var ∧ x.offset ≤ y.offset) →
+      Node.eval ls ρ (List.foldl (fun n1 pn => Node.subsume p₁ n1 pn.1 pn.2) n1 l) ≤ m →
+      Node.eval ls ρ n₁ ≤ m from
+    this n₁ (fun _ => id) (.inl rfl) (fun x h => .inl ⟨x, h, rfl, Nat.le_refl _⟩) hf
+  clear hf
+  induction l with intro n1 hL hK hJ hf
+  | nil =>
+    refine Node.eval_le.2 ⟨?_, fun x hx => ?_⟩
+    · obtain hK | ⟨-, hK | ⟨p₂, n₂, hne, h₂, hsub, hc⟩⟩ := hK
+      · exact Nat.le_trans (hK ▸ Node.const_le_eval) hf
+      · obtain ⟨y, hy, hc⟩ := hK
+        obtain ⟨y', hy', e, le⟩ | hd := hJ _ hy
+        · refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy') hf)
+          have : 0 < evalParam ls ρ y'.var := by
+            simp [allNZ] at nz; exact nz _ (wf₁ _ (hL _ hy'))
+          simp only [VarNode.eval]; omega
+        · refine Nat.le_trans ?_ (domle _ hd)
+          obtain ⟨p₂, n₂, y', hne, h₂, hsub, hy', e, le⟩ := hd
+          have : 0 < evalParam ls ρ y'.var := by
+            simp [allNZ] at nz; exact nz _ (subset_mem hsub (wfa _ _ h₂ _ hy'))
+          simp only [VarNode.eval, ← e]; omega
+      · exact Nat.le_trans hc (evalq _ _ hne h₂ hsub)
+    · obtain ⟨y, hy, e, le⟩ | hd := hJ _ hx
+      · refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy) hf)
+        simp only [VarNode.eval, ← e]; omega
+      · exact domle _ hd
+  | cons pn l ih =>
+    simp only [List.mem_cons, forall_eq_or_imp] at hmem
+    obtain ⟨h₂, hmem'⟩ := hmem
+    refine ih hmem' _ (fun x h => hL _ (Node.subsume_var_subset h)) ?_ (fun x hx => ?_) hf
+    · by_cases hc : (Node.subsume p₁ n1 pn.1 pn.2).const = n1.const
+      · rw [hc]; exact hK
+      obtain ⟨hsub, hd⟩ := Node.subsume_const_drop hc
+      obtain heq | hzero := Node.subsume_const_cases p₁ n1 pn.1 pn.2
+      · cases hc heq
+      have hc1 : n1.const = n₁.const := by
+        rcases hK with h | ⟨h, -⟩
+        · exact h
+        · cases hc (hzero.trans h.symm)
+      refine .inr ⟨hzero, ?_⟩
+      by_cases hpe : pn.1 = p₁
+      · subst hpe
+        have : pn.2 = n₁ := by cases h₁.symm.trans h₂; rfl
+        subst this
+        obtain ⟨hne', -⟩ | ⟨y, hy, hle⟩ := hd
+        · exact absurd rfl hne'
+        · exact .inl ⟨y, hy, hc1 ▸ hle⟩
+      · refine .inr ⟨pn.1, pn.2, hpe, h₂, hsub, ?_⟩
+        obtain ⟨-, hle⟩ | ⟨y, hy, hle⟩ := hd
+        · exact hc1 ▸ Nat.le_trans hle Node.const_le_eval
+        · refine hc1 ▸ Nat.le_trans hle ?_
+          have : 0 < evalParam ls ρ y.var := by
+            simp [allNZ] at nz
+            exact nz _ (subset_mem hsub (wfa _ _ h₂ _ hy))
+          refine Nat.le_trans ?_ (Node.var_le_eval hy)
+          simp only [VarNode.eval]; omega
+    · obtain ⟨y, hy, e, le⟩ | hd := hJ _ hx <;> [skip; exact .inr hd]
+      obtain hv | ⟨hsub, hlen, hv⟩ := Node.subsume_var_cases p₁ n1 pn.1 pn.2
+      · exact .inl ⟨y, hv ▸ hy, e, le⟩
+      by_cases hy' : y ∈ (Node.subsume p₁ n1 pn.1 pn.2).var
+      · exact .inl ⟨y, hy', e, le⟩
+      obtain ⟨z, hz, ez, lez⟩ := subsumeVars_dominated hy (hv ▸ hy')
+      have hpe : pn.1 ≠ p₁ := fun h => hlen (h ▸ rfl)
+      exact .inr ⟨pn.1, pn.2, z, hpe, h₂, hsub, hz, ez.trans e, Nat.le_trans le lez⟩
+
+/-- One step of `subsumption`: the key being minimized is updated, or erased if it drained,
+and no other key changes. -/
+theorem NormLevel.subsumption_step_get? (acc : NormLevel) (n₁ : Node) (p₁ p : List Name) :
+    (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁
+     else acc.insert p₁ (acc.minimize p₁ n₁)).get? p =
+    if p₁ = p then (if (acc.minimize p₁ n₁).isEmpty then none else some (acc.minimize p₁ n₁))
+    else acc.get? p := by
+  split <;>
+    simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_erase,
+      Std.TreeMap.getElem?_insert] <;>
+    split <;> split <;> simp_all
+
+/-- `subsumption` only shrinks the variable lists, at unchanged keys, so it preserves the
+half of `WF` saying that every variable recorded at a key is an element of it. -/
+theorem NormLevel.subsumption_vars {s : NormLevel} (wf : s.WF) :
+    ∀ p n, s.subsumption.get? p = some n → (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p := by
+  rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  generalize s.toList = l at hmem
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (∀ pn ∈ l, s.get? pn.1 = some pn.2) →
+      (∀ p n, acc.get? p = some n → (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p) →
+      ∀ p n, (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n →
+        (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p from this _ _ hmem fun p n h => (wf p n h).2
+  clear hmem; intro l
+  induction l with | nil => exact fun _ _ => id | cons pn l ih
+  intro acc hl hacc
+  refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h => ?_
+  rw [subsumption_step_get?] at h
+  split at h
+  · split at h <;> [cases h; skip]
+    cases h; rename_i hp _; subst hp
+    have := (wf _ _ (hl _ (.head _))).2
+    exact ⟨fun v hv => this.1 _ (minimize_var_subset hv), this.2⟩
+  · exact hacc _ _ h
+
+/-- A variable that minimization drops is dropped in favour of one with the same name at a
+strictly smaller key. -/
+theorem NormLevel.minimize_var_dominated {acc : NormLevel} {p₁ n₁ x}
+    (hx : x ∈ n₁.var) (h : x ∉ (acc.minimize p₁ n₁).var) :
+    ∃ p₂ n₂ y, acc.get? p₂ = some n₂ ∧ y ∈ n₂.var ∧ y.var = x.var ∧
+      p₂ ≠ p₁ ∧ ∀ z ∈ p₂, z ∈ p₁ := by
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h
+  have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  generalize acc.toList = l at h hmem
+  suffices ∀ (l : List (List Name × Node)) (n : Node),
+      (∀ pn ∈ l, acc.get? pn.1 = some pn.2) → x ∈ n.var →
+      x ∉ (List.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n l).var →
+      ∃ p₂ n₂ y, acc.get? p₂ = some n₂ ∧ y ∈ n₂.var ∧ y.var = x.var ∧
+        p₂ ≠ p₁ ∧ ∀ z ∈ p₂, z ∈ p₁ from this _ _ hmem hx h
+  clear hx h hmem; intro l
+  induction l with
+  | nil => exact fun n _ hx h => absurd hx h
+  | cons pn l ih =>
+    intro n hl hx h
+    by_cases hx' : x ∈ (Node.subsume p₁ n pn.1 pn.2).var
+    · exact ih _ (fun _ h => hl _ (.tail _ h)) hx' h
+    · obtain heq | ⟨hsub, hlen, heq⟩ := Node.subsume_var_cases p₁ n pn.1 pn.2
+      · rw [heq] at hx'; exact absurd hx hx'
+      · rw [heq] at hx'
+        obtain ⟨y, hy, e, -⟩ := subsumeVars_dominated hx hx'
+        exact ⟨pn.1, pn.2, y, hl _ (.head _), hy, e,
+          fun he => hlen (by rw [he]), fun _ hz => subset_mem hsub hz⟩
+
+/-- `s'` covers `s`: every variable recorded in `s` is still recorded in `s'`, at a subset of
+its key. This is all of a map that `Dom`, hence `Feas`, looks at. -/
+def NormLevel.Covers (s' s : NormLevel) : Prop :=
+  ∀ p n x, s.get? p = some n → x ∈ n.var →
+    ∃ q m y, s'.get? q = some m ∧ y ∈ m.var ∧ y.var = x.var ∧ ∀ z ∈ q, z ∈ p
+
+/-- `subsumption` only removes variables from a node, and never the last witness for a name:
+a removed one is still recorded at a strictly smaller key, possibly after further removals
+there. So the subsumed map covers the original, and its entries are entries of it. -/
+theorem NormLevel.subsumption_covers {s : NormLevel} :
+    (∀ p n, s.subsumption.get? p = some n →
+      ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) ∧ s.subsumption.Covers s := by
+  rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  generalize s.toList = l at hmem
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (∀ pn ∈ l, s.get? pn.1 = some pn.2) →
+      (∀ p n, acc.get? p = some n → ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) →
+      acc.Covers s →
+      (∀ p n, (List.foldl (fun acc pn =>
+          let n := acc.minimize pn.1 pn.2
+          if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n →
+        ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) ∧
+      (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).Covers s from
+    this _ _ hmem (fun p n h => ⟨n, h, fun _ => id⟩)
+      (fun p n x h hx => ⟨p, n, x, h, hx, rfl, fun _ => id⟩)
+  clear hmem; intro l
+  induction l with | nil => exact fun _ _ h1 h2 => ⟨h1, h2⟩ | cons pn l ih
+  obtain ⟨p₁, n₁⟩ := pn
+  intro acc hl hsub hcov
+  have h₁ : s.get? p₁ = some n₁ := hl _ (.head _)
+  refine ih _ (fun _ h => hl _ (.tail _ h)) (fun p n h => ?_) (fun p n x hp hx => ?_)
+  · rw [subsumption_step_get?] at h
+    split at h
+    · split at h <;> [cases h; skip]
+      cases h; rename_i hp _; subst hp
+      exact ⟨n₁, h₁, fun x hx => minimize_var_subset hx⟩
+    · exact hsub _ _ h
+  · obtain ⟨q, m, y, hq, hy, e, hqp⟩ := hcov _ _ _ hp hx
+    by_cases hqp₁ : q = p₁
+    · subst hqp₁
+      -- the write lands on the key covering `x`: either the variable survives it, or it is
+      -- dominated at a smaller key, which this step leaves alone
+      obtain ⟨n₀, h₀, hy₀⟩ := hsub _ _ hq
+      cases h₀.symm.trans h₁
+      by_cases hmin : y ∈ (acc.minimize q n₁).var
+      · refine ⟨q, _, y, ?_, hmin, e, hqp⟩
+        rw [subsumption_step_get?, if_pos rfl, if_neg]
+        simp only [Node.isEmpty, Bool.and_eq_true, List.isEmpty_iff, not_and]
+        rintro - he; simp [he] at hmin
+      · obtain ⟨p₂, n₂, z, h₂, hz, e₂, hne, hp₂⟩ := minimize_var_dominated (hy₀ _ hy) hmin
+        exact ⟨p₂, n₂, z, by rw [subsumption_step_get?, if_neg (Ne.symm hne)]; exact h₂,
+          hz, e₂.trans e, fun w hw => hqp _ (hp₂ _ hw)⟩
+    · exact ⟨q, m, y, by rw [subsumption_step_get?, if_neg (Ne.symm hqp₁)]; exact hq,
+        hy, e, hqp⟩
+
+theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) :
     s.subsumption.eval ls ρ = s.eval ls ρ := by
-  unfold NormLevel.subsumption
-  rw [Std.TreeMap.foldl_eq_foldl_toList]
-  simp only [Bool.false_eq_true, if_false]
-  apply subsumptionOuterList_eval
-  · intro x hx
-    exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hx
-  · exact Std.TreeMap.distinct_keys_toList
+  rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  have nd : (s.toList.map Prod.fst).Nodup := by simpa using Std.TreeMap.nodup_keys (t := s)
+  generalize s.toList = l at hmem nd
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (l.map Prod.fst).Nodup →
+      (∀ p n, (p, n) ∈ l → acc.get? p = some n) →
+      (∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) →
+      eval ls ρ acc = eval ls ρ s →
+      eval ls ρ (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l) = eval ls ρ s from
+    this _ _ nd (fun _ _ => hmem _) (fun _ _ h => (wf _ _ h).2.1) rfl
+  clear hmem nd; intro l
+  induction l with | nil => exact fun acc _ _ _ eq => eq | cons pn l ih
+  have ⟨p₁, n₁⟩ := pn; intro acc nd hl wfa eq
+  simp only [List.map_cons, List.nodup_cons] at nd
+  have h₁ := hl _ _ (.head _)
+  -- a drained key is erased rather than kept, which is the same for `eval`
+  have hins := subsumption_step_get? acc n₁ p₁
+  have hmin_le m
+      (H : ∀ a b, (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁
+        else acc.insert p₁ (acc.minimize p₁ n₁)).get? a = some b →
+        evalPath ls ρ a (Node.eval ls ρ b) ≤ m)
+      (nz : allNZ ls ρ p₁) : Node.eval ls ρ (acc.minimize p₁ n₁) ≤ m := by
+    by_cases he : (acc.minimize p₁ n₁).isEmpty
+    · simp [Node.isEmpty, List.isEmpty_iff] at he; simp [Node.eval, he.1, he.2]
+    · have hget : (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁
+          else acc.insert p₁ (acc.minimize p₁ n₁)).get? p₁ = some (acc.minimize p₁ n₁) := by
+        rw [hins p₁, if_pos rfl, if_neg he]
+      have := H _ _ hget
+      rw [evalPath_le] at this; exact this nz
+  refine ih _ nd.2 (fun p n h => ?_) (fun p n h v hv => ?_) ((ext_le fun m => ?_).trans eq)
+  · have hne : p₁ ≠ p := fun e => nd.1 (by rw [e]; exact List.mem_map_of_mem h)
+    exact (hins p).trans (if_neg hne) ▸ hl _ _ (.tail _ h)
+  · rw [hins p] at h; split at h
+    · split at h <;> [cases h; skip]
+      cases h; rename_i hp _; subst hp
+      exact wfa _ _ h₁ _ (minimize_var_subset hv)
+    · exact wfa _ _ h _ hv
+  · simp only [eval_le]; constructor <;> intro H p n h
+    · by_cases hp : p = p₁
+      · subst hp; cases h₁.symm.trans h
+        refine evalPath_le.2 fun nz => ?_
+        refine (minimize_eval_iff wfa h₁ (fun q nq hne hq => ?_) nz).1 (hmin_le _ H nz)
+        exact H _ _ ((hins q).trans (if_neg hne.symm) ▸ hq)
+      · exact H p n ((hins p).trans (if_neg (Ne.symm hp)) ▸ h)
+    · rw [hins p] at h; split at h <;> [skip; exact H _ _ h]
+      split at h <;> [cases h; skip]
+      cases h; rename_i hp _; subst hp
+      refine evalPath_le.2 fun nz => ?_
+      have := H _ _ h₁; rw [evalPath_le] at this
+      exact Nat.le_trans minimize_eval_le (this nz)
 
 theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') :
     (normalize u).eval ls ρ = u'.eval ρ := by
-  simp [normalize, NormLevel.subsumption_eval]
-  exact normalizeAux_eval hu (by simp) .nil
+  simp [normalize]
+  refine have h1 := ?_; by
+    rw [NormLevel.subsumption_eval (normalizeAux_wf (by simp) h1)]
+    exact normalizeAux_eval hu (by simp) h1
+  simp [NormLevel.WF]
+
+theorem normalize_vars_sorted : ∀ p n, (normalize u).get? p = some n →
+    (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p :=
+  NormLevel.subsumption_vars (normalizeAux_wf (by simp) (by simp [NormLevel.WF]))
+
+theorem normalize_vars : ∀ p n, (normalize u).get? p = some n → ∀ v ∈ n.var, v.var ∈ p :=
+  fun _ _ h => (normalize_vars_sorted _ _ h).1
+
+theorem normalize_sorted : ∀ p n, (normalize u).get? p = some n → Sorted p :=
+  fun _ _ h => (normalize_vars_sorted _ _ h).2
+
+/-- Soundness of `NormLevel.le`, Theorem 39 of the paper: it reports `true` only when every
+sublevel of `l₁` is dominated. Each entry of `l₁` is compared against a fold over `l₂`,
+where every entry discharges from the node what it can, and the fold stops (returning
+`none`) once nothing is left to discharge; so the fold ends in `none` only if the node is
+bounded by the total of `l₂`. -/
+theorem NormLevel.le_eval {l₁ l₂ : NormLevel}
+    (wf₂ : ∀ p n, l₂.get? p = some n → ∀ v ∈ n.var, v.var ∈ p)
+    (h : l₁.le l₂) : l₁.eval ls ρ ≤ l₂.eval ls ρ := by
+  refine NormLevel.eval_le.2 fun p₁ n₁ h₁ => evalPath_le.2 fun nz => ?_
+  -- an entry of `l₂` at a key below `p₁` is bounded by the total, on a live condition set
+  have hbd p₂ n₂ (h₂ : l₂.get? p₂ = some n₂) (hsub : subset compare p₂ p₁) :
+      (∀ v ∈ n₂.var, 0 < evalParam ls ρ v.var) ∧ Node.eval ls ρ n₂ ≤ l₂.eval ls ρ := by
+    have hnz : allNZ ls ρ p₂ := allNZ_mono (fun _ h => subset_mem hsub h) nz
+    refine ⟨fun v hv => ?_, ?_⟩
+    · simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnz
+      exact hnz _ (wf₂ _ _ h₂ _ hv)
+    · have := evalPath_le.1 (NormLevel.eval_le.1 (Nat.le_refl (l₂.eval ls ρ)) _ _ h₂)
+      exact this hnz
+  rw [NormLevel.le, Std.TreeMap.all_eq_all_toList, List.all_eq_true] at h
+  have hf := h (p₁, n₁) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (by simpa using h₁))
+  simp only [Std.TreeMap.foldlM_eq_foldlM_toList, Option.isNone_iff_eq_none] at hf
+  have hmem pn (h : pn ∈ l₂.toList) : l₂.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  clear h₁ h
+  generalize l₂.toList = l at hf hmem
+  induction l generalizing n₁ with
+  | nil => simp at hf
+  | cons pn l ih =>
+    simp only [List.foldlM_cons] at hf
+    simp only [List.mem_cons, forall_eq_or_imp] at hmem
+    by_cases hs : subset compare pn.1 p₁
+    · refine (Node.subsumeBy_eval_iff (same := false) (n₂ := pn.2)
+        (hbd _ _ hmem.1 hs).1 (hbd _ _ hmem.1 hs).2).1 ?_
+      by_cases he : (n₁.subsumeBy false pn.2).isEmpty
+      · simp [Node.eval_empty he]
+      · exact ih _ (by simpa [hs, he] using hf) hmem.2
+    · exact ih _ (by simpa [hs] using hf) hmem.2
 
 theorem Node.eval_congr {a b : Node} (H : a == b) : a.eval ls ρ = b.eval ls ρ := by
   simp +instances [instBEqNode] at H; simp [H, eval]
 
-private theorem evalList_congr {a b : List (List Name × Node)} (H : a == b) (init : Nat) :
-    a.foldl (init := init) (fun n x => max' n (evalPath ls ρ x.1 (x.2.eval ls ρ))) =
-    b.foldl (init := init) (fun n x => max' n (evalPath ls ρ x.1 (x.2.eval ls ρ))) := by
-  induction a generalizing b init with
-  | nil =>
-    cases b <;> simp_all
-  | cons x xs ih =>
-    cases b with
-    | nil => simp_all
-    | cons y ys =>
-      rcases x with ⟨px, nx⟩
-      rcases y with ⟨py, ny⟩
-      simp [BEq.beq, List.beq] at H
-      have hp : px = py := LawfulBEq.eq_of_beq H.1.1
-      have hv : nx.var = ny.var := LawfulBEq.eq_of_beq H.1.2.2
-      have hn := Node.eval_congr (ls := ls) (ρ := ρ) (show nx == ny by
-        simp +instances [instBEqNode, H.1.2.1, hv])
-      cases hp
-      simp only [List.foldl_cons]
-      rw [hn]
-      exact ih H.2 _
-
 theorem NormLevel.eval_congr {a b : NormLevel} (H : a == b) : a.eval ls ρ = b.eval ls ρ := by
-  change a.toList == b.toList at H
+  simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList,
+    Bool.and_eq_true, List.all_eq_true] at H
+  suffices ∀ {a b : NormLevel}, (∀ x ∈ a.toList, b.get? x.1 == some x.2) →
+      a.eval ls ρ ≤ b.eval ls ρ from Nat.le_antisymm (this H.1) (this H.2)
+  clear a b H; intro a b H
   simp only [eval, Std.TreeMap.foldl_eq_foldl_toList]
-  exact evalList_congr H 0
-
-theorem NormLevel.le_eval {a b : NormLevel} (h : a.le b) :
-    a.eval ls ρ ≤ b.eval ls ρ := by
-  rw [NormLevel.eval_le]
-  intro p₁ n₁ hget₁
-  have hmem₁ : (p₁, n₁) ∈ a.toList :=
-    Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 hget₁
-  simp only [NormLevel.le, List.all_eq_true] at h
-  have hentry := h (p₁, n₁) hmem₁
-  dsimp only at hentry
-  split at hentry
-  · rename_i hz
-    simp only [Bool.and_eq_true] at hz
-    have hc : n₁.const = 0 := of_decide_eq_true hz.1
-    have hv : n₁.var = [] := by simpa using hz.2
-    simp [Node.eval, hc, hv, evalPath]
-  · simp only [List.any_eq_true] at hentry
-    rcases hentry with ⟨⟨p₂, n₂⟩, hmem₂, hcmp⟩
-    dsimp only at hcmp
-    simp only [Bool.and_eq_true, Bool.or_eq_true, List.any_eq_true] at hcmp
-    have hsub := hcmp.1.1.2
-    have hconst := hcmp.1.2
-    have hvars := hcmp.2
-    have hget₂ : b.get? p₂ = some n₂ :=
-      Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hmem₂
-    apply evalPath_le.2
-    intro hnz₁
-    have hnz₂ := allNZ_mono (subset_subset hsub) hnz₁
-    have hnode : n₁.eval ls ρ ≤ n₂.eval ls ρ := by
-      apply Node.eval_le.2
-      constructor
-      · rcases hconst with hc | ⟨w, hw, hpath, hoff⟩
-        · exact Nat.le_trans (of_decide_eq_true hc)
-            (Node.eval_le.1 (Nat.le_refl _) |>.1)
-        · have hpath' : w.var ∈ p₂ := by simpa using hpath
-          exact Nat.le_trans
-            (const_le_activeVar_eval hpath' hnz₂ (of_decide_eq_true hoff))
-            (Node.eval_le.1 (Nat.le_refl _) |>.2 w hw)
-      · intro v hv
-        rcases leVars_dominated hvars hv with ⟨w, hw, hvar, hoff⟩
-        exact Nat.le_trans (varNode_eval_mono hvar hoff)
-          (Node.eval_le.1 (Nat.le_refl _) |>.2 w hw)
-    exact Nat.le_trans hnode
-      (evalPath_le.1 (NormLevel.eval_le.1 (Nat.le_refl _) p₂ n₂ hget₂) hnz₂)
+  rw [← a.toList.reverse_reverse] at H ⊢; generalize a.toList.reverse = a at H ⊢
+  simp only [List.mem_reverse, Std.TreeMap.get?_eq_getElem?, List.foldl_reverse] at H ⊢
+  induction a with | nil => exact Nat.zero_le _ | cons p l ih; let (x, y) := p
+  simp only [List.mem_cons, or_imp, forall_and, forall_eq, List.foldr_cons] at H ⊢
+  refine Nat.max_le.2 ⟨ih H.2, ?_⟩
+  let ⟨y', h1, h2⟩ := Option.beq_some_iff.1 H.1
+  have H := Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 h1
+  rw [← b.toList.reverse_reverse] at H ⊢; generalize b.toList.reverse = b at H ⊢
+  simp only [List.mem_reverse, List.foldl_reverse] at H ⊢
+  induction b with | nil => cases H | cons p l ih; let (x, y) := p
+  simp; obtain ⟨⟩ | ⟨_, (H : _ ∈ l)⟩ := H
+  · exact Node.eval_congr h2 ▸ Nat.le_max_right ..
+  · exact Nat.le_trans (ih H) (Nat.le_max_left ..)
+
+/-!
+### Reconstruction
+
+The value of a `Tree` is the value of the level it reifies to: a tree node contributes its
+own sublevels, and every child contributes under the `imax` guard of the variable labelling
+the edge into it. That edge guard is what makes the tree shape meaningful — a node at path
+`[a₁, …, aₙ]` (innermost first) is guarded by all of `a₁, …, aₙ` — and it is also what makes
+the tree carry sublevels of its own, since `imax x a` is at least `a` when `a ≠ 0`.
+-/
 
-end Normalize
+mutual
+
+def Tree.eval (ls : List Name) (ρ : List Nat) : Tree → Nat
+  | ⟨const, var, child⟩ => max' (Node.eval ls ρ ⟨const, var⟩) (Tree.evalChild ls ρ child)
+
+def Tree.evalChild (ls : List Name) (ρ : List Nat) : List (Name × Tree) → Nat
+  | [] => 0
+  | (a, t) :: l =>
+    max' (Lean.Nat.imax (Tree.eval ls ρ t) (evalParam ls ρ a)) (Tree.evalChild ls ρ l)
+
+end
+
+/-- The value of the optional level accumulated by `reify`. -/
+def evalOpt (ρ : Name → Nat) (μ : LMVarId → Nat) : Option Level → Nat
+  | none => 0
+  | some l => Level.eval ρ μ l
+
+@[simp] theorem evalOpt_none : evalOpt ρ μ none = 0 := rfl
+@[simp] theorem evalOpt_some : evalOpt ρ μ (some l) = Level.eval ρ μ l := rfl
+
+theorem imax_eq_ite : Lean.Nat.imax a b = if b = 0 then 0 else max' a b := rfl
+
+theorem imax_zero_left : Lean.Nat.imax 0 a = a := by rw [imax_eq_ite]; split <;> omega
+
+theorem Node.eval_const {var : List VarNode} :
+    Node.eval ls ρ ⟨c, var⟩ = max' c (Node.eval ls ρ ⟨0, var⟩) :=
+  ext_le fun x => by simp [Node.eval_le, Nat.max_le]
+
+theorem Node.eval_cons {var : List VarNode} :
+    Node.eval ls ρ ⟨c, a :: var⟩ = max' (VarNode.eval ls ρ a) (Node.eval ls ρ ⟨c, var⟩) :=
+  ext_le fun x => by simp [Node.eval_le, Nat.max_le, and_left_comm]
+
+theorem eval_mkMax :
+    Level.eval ρ μ (Tree.reify.mkMax l o) = max' (Level.eval ρ μ l) (evalOpt ρ μ o) := by
+  cases o <;> simp [Tree.reify.mkMax, evalOpt, Level.eval]
+
+theorem eval_addOffset : Level.eval ρ μ (l.addOffset k) = Level.eval ρ μ l + k := by
+  simp only [Level.addOffset]
+  induction k generalizing l with
+  | zero => rfl
+  | succ k ih => rw [Level.addOffsetAux, ih]; simp [Level.eval]; omega
+
+theorem eval_ofNat : Level.eval ρ μ (Level.ofNat k) = k := by
+  induction k with
+  | zero => rfl
+  | succ k ih => simp [Level.ofNat, Level.eval, ih]
+
+theorem eval_varFold (var : List VarNode) (o : Option Level) :
+    evalOpt (evalParam ls ρ) μ (var.foldr (init := o) fun n r =>
+      some (Tree.reify.mkMax (Level.addOffset (.param n.var) n.offset) r)) =
+    max' (Node.eval ls ρ ⟨0, var⟩) (evalOpt (evalParam ls ρ) μ o) := by
+  induction var with | nil => simp [Node.eval] | cons a var ih
+  simp only [List.foldr_cons, evalOpt_some, eval_mkMax, eval_addOffset, Level.eval, ih,
+    Node.eval_cons, VarNode.eval]; omega
+
+/-- The two shapes `plainOffset?` accepts. -/
+theorem Tree.plainOffset?_eq {a : Name} {t : Tree} {k : Nat} (h : plainOffset? a t = some k) :
+    t = ⟨0, [], []⟩ ∧ k = 0 ∨ t = ⟨0, [⟨a, k⟩], []⟩ := by
+  unfold plainOffset? at h
+  split at h
+  · exact .inl ⟨rfl, by simpa using h.symm⟩
+  · rename_i v _
+    split at h <;> [skip; cases h]
+    cases h; rename_i hv
+    exact .inr (by rw [← eq_of_beq hv])
+  · cases h
+
+/-- Dropping the `imax` guard of a plain child is exact modulo the node's constant: the two
+differ only when the edge variable is zero, where the plain form contributes `k ≤ const`. -/
+theorem Tree.plainOffset?_eval {a : Name} {t : Tree} {k const : Nat}
+    (h : plainOffset? a t = some k) (hk : k ≤ const) :
+    max' const (Lean.Nat.imax (eval ls ρ t) (evalParam ls ρ a)) =
+    max' const (evalParam ls ρ a + k) := by
+  obtain ⟨rfl, rfl⟩ | rfl := plainOffset?_eq h
+  · rw [show eval ls ρ ⟨0, [], []⟩ = 0 from by simp [eval, evalChild, Node.eval],
+      imax_zero_left]
+    omega
+  · rw [show eval ls ρ ⟨0, [⟨a, k⟩], []⟩ = evalParam ls ρ a + k from by
+      simp [eval, evalChild, Node.eval, VarNode.eval], imax_eq_ite]
+    split <;> omega
+
+/-- A child emitted plainly at exactly the node's constant makes that constant redundant. -/
+theorem Tree.reifyChild_ge {const : Nat} : ∀ child : List (Name × Tree),
+    (child.any fun c => plainOffset? c.1 c.2 == some const) →
+    const ≤ evalOpt (evalParam ls ρ) μ (child.foldr (reify.mkChild const) none)
+  | (n, t) :: child, h => by
+    rw [List.foldr_cons, reify.mkChild]
+    simp only [List.any_cons, Bool.or_eq_true, beq_iff_eq] at h
+    -- either this child is the witness, in which case it is emitted as `n + const`, or the
+    -- witness is further down and the fold maxes its value in
+    obtain h | h := h
+    · rw [h]; dsimp only; rw [if_pos (Nat.le_refl const)]
+      simp only [evalOpt_some, eval_mkMax, eval_addOffset, Level.eval]
+      omega
+    · have ih := reifyChild_ge (ls := ls) (ρ := ρ) (μ := μ) child h
+      split <;> [split; skip] <;>
+        simp only [evalOpt_some, eval_mkMax] <;> omega
+
+mutual
+
+theorem Tree.reify_eval (t : Tree) : t.reify.eval (evalParam ls ρ) μ = t.eval ls ρ := by
+  obtain ⟨const, var, child⟩ := t
+  rw [eval]
+  simp only [reify]
+  have h1 := eval_varFold (ls := ls) (ρ := ρ) (μ := μ) var
+    (child.foldr (reify.mkChild const) none)
+  have hc := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) const child
+  rw [Node.eval_const (c := const)]
+  split <;> [rename_i heq; rename_i l heq]
+  · rw [heq, evalOpt_none] at h1
+    rw [eval_ofNat]; omega
+  · rw [heq, evalOpt_some] at h1
+    split <;> rename_i hd
+    · -- the constant is dropped: either it is zero, or some child already covers it
+      simp only [Bool.or_eq_true, beq_iff_eq] at hd
+      rw [h1]
+      obtain rfl | hd := hd
+      · omega
+      · have := Tree.reifyChild_ge (ls := ls) (ρ := ρ) (μ := μ) (const := const) child hd
+        omega
+    · simp only [Level.eval, eval_ofNat, h1, Nat.max_eq_max]; omega
+
+theorem Tree.reifyChild_eval (const : Nat) (child : List (Name × Tree)) :
+    max' const (evalOpt (evalParam ls ρ) μ (child.foldr (reify.mkChild const) none)) =
+    max' const (evalChild ls ρ child) := by
+  match child with
+  | [] => rfl
+  | (n, t) :: child =>
+    rw [List.foldr_cons, evalChild, reify.mkChild]
+    have ht := reify_eval (ls := ls) (ρ := ρ) (μ := μ) t
+    have ih := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) const child
+    split <;> rename_i k h
+    · split <;> rename_i hk
+      · have hp := Tree.plainOffset?_eval (ls := ls) (ρ := ρ) h hk
+        simp only [evalOpt_some, eval_mkMax, eval_addOffset, Level.eval] at *
+        omega
+      · simp only [evalOpt_some, eval_mkMax, Level.eval, ht] at *
+        omega
+    · simp only [evalOpt_some, eval_mkMax, Level.eval, ht] at *
+      omega
+
+end
+
+/-- `Tree.At t p t'` says `t'` is the subtree of `t` at path `p`, listed innermost first,
+the way `Tree.modify` takes it. -/
+inductive Tree.At : Tree → List Name → Tree → Prop
+  | nil : At t [] t
+  | cons (h : At t p t') (hm : (a, t'') ∈ t'.child) : At t (a :: p) t''
+
+theorem Tree.eval_eq (t : Tree) :
+    eval ls ρ t = max' (Node.eval ls ρ ⟨t.const, t.var⟩) (evalChild ls ρ t.child) := by
+  cases t; rw [eval]
+
+theorem Tree.At.append (h : At t' q t'') (hm : (a, t') ∈ t.child) :
+    At t (q ++ [a]) t'' := by
+  induction h with
+  | nil => exact .cons .nil hm
+  | cons _ hm' ih => exact .cons ih hm'
+
+/-- A path passes through all of its tails. -/
+theorem Tree.At.suffix {t : Tree} : ∀ {path t' q}, At t path t' → q <:+ path → ∃ t'', At t q t'' := by
+  intro path
+  induction path with
+  | nil => intro t' q _ hq; cases List.suffix_nil.1 hq; exact ⟨t, .nil⟩
+  | cons a p ih =>
+    intro t' q h hq
+    obtain rfl | hq := List.suffix_cons_iff.1 hq
+    · exact ⟨t', h⟩
+    · cases h; rename_i t₁ h _; exact ih h hq
+
+theorem Tree.At.nil_inv (h : At t [] t') : t' = t := by cases h; rfl
+
+/-- Inverting `At.append`: a nonempty path is a child of the root followed by the rest. -/
+theorem Tree.At.append_inv : ∀ {q t t''}, At t (q ++ [a]) t'' →
+    ∃ t₁, (a, t₁) ∈ t.child ∧ At t₁ q t'' := by
+  intro q
+  induction q with
+  | nil =>
+    intro t t'' h
+    cases h; rename_i t₁ h hm
+    cases h.nil_inv
+    exact ⟨t'', hm, .nil⟩
+  | cons b q ih =>
+    intro t t'' h
+    simp only [List.cons_append] at h
+    cases h; rename_i t₁ h hm
+    obtain ⟨t₂, hm₂, h₂⟩ := ih h
+    exact ⟨t₂, hm₂, .cons h₂ hm⟩
+
+/-- Paths only look at the children, so replacing the root's own data leaves them all in
+place; only the empty path sees the difference. -/
+theorem Tree.At.of_child_eq {t u : Tree} (hc : u.child = t.child) :
+    ∀ {p t'}, At t p t' → At u p t' ∨ (p = [] ∧ t' = t) := by
+  intro p
+  induction p with
+  | nil => intro t' h; exact .inr ⟨rfl, h.nil_inv⟩
+  | cons a q ih =>
+    intro t'' h
+    cases h; rename_i t₁ h hm
+    obtain h' | ⟨rfl, rfl⟩ := ih h
+    · exact .inl (.cons h' hm)
+    · exact .inl (.cons .nil (by rw [hc]; exact hm))
+
+theorem Tree.mem_le {l : List (Name × Tree)} (hm : (a, t) ∈ l) :
+    Lean.Nat.imax (eval ls ρ t) (evalParam ls ρ a) ≤ evalChild ls ρ l := by
+  induction l with
+  | nil => cases hm
+  | cons b l ih =>
+    obtain ⟨b, t'⟩ := b
+    rw [evalChild]
+    obtain h | hm := List.mem_cons.1 hm
+    · cases h; exact Nat.le_max_left ..
+    · exact Nat.le_trans (ih hm) (Nat.le_max_right ..)
+
+theorem evalPath_cons_imax :
+    evalPath ls ρ (a :: p) c ≤ evalPath ls ρ p (Lean.Nat.imax c (evalParam ls ρ a)) := by
+  rw [evalPath_cons]
+  exact evalPath_mono <| by
+    by_cases h : evalParam ls ρ a = 0 <;>
+      simp [imax_eq_ite, h, Nat.pos_of_ne_zero, Nat.le_max_left]
+
+theorem evalPath_cons_edge :
+    evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤
+      evalPath ls ρ p (Lean.Nat.imax c (evalParam ls ρ a)) := by
+  rw [evalPath_cons]
+  exact evalPath_mono <| by
+    by_cases h : evalParam ls ρ a = 0 <;>
+      simp [imax_eq_ite, h, Nat.pos_of_ne_zero, Nat.le_max_right]
+
+theorem evalPath_append_single (ha : evalParam ls ρ a ≠ 0) :
+    evalPath ls ρ (p ++ [a]) c = evalPath ls ρ p c := by
+  simp [evalPath, allNZ, List.all_append, Nat.pos_of_ne_zero ha]
+
+theorem Tree.At.le (h : At t p t') :
+    evalPath ls ρ p (eval ls ρ t') ≤ eval ls ρ t := by
+  induction h with
+  | nil => simp [evalPath, allNZ]
+  | cons _ hm ih =>
+    refine Nat.le_trans evalPath_cons_imax (Nat.le_trans (evalPath_mono ?_) ih)
+    exact Nat.le_trans (mem_le hm) (eval_eq _ ▸ Nat.le_max_right ..)
+
+theorem Tree.At.edge_le (h : At t (a :: p) t') :
+    evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ eval ls ρ t := by
+  cases h with | @cons _ t'' _ _ h' hm => ?_
+  refine Nat.le_trans (evalPath_cons_edge (c := eval ls ρ t'))
+    (Nat.le_trans (evalPath_mono ?_) h'.le)
+  exact Nat.le_trans (mem_le hm) (eval_eq t'' ▸ Nat.le_max_right ..)
+
+mutual
+
+/-- A tree is bounded by `m` as soon as all the sublevels it reifies to are: the ones
+recorded at its nodes, and the `V(p, a, 0)` contributed by the edge into each node. -/
+theorem Tree.eval_le_of (t : Tree)
+    (h1 : ∀ p t', At t p t' → evalPath ls ρ p (Node.eval ls ρ ⟨t'.const, t'.var⟩) ≤ m)
+    (h2 : ∀ a p t', At t (a :: p) t' → evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ m) :
+    eval ls ρ t ≤ m := by
+  obtain ⟨const, var, child⟩ := t
+  rw [eval]
+  refine Nat.max_le.2 ⟨h1 [] _ .nil, evalChild_le_of child ?_ ?_ ?_⟩
+  · exact fun a t' hm p t'' hat => h1 _ _ (hat.append hm)
+  · exact fun a t' hm b p t'' hat => h2 _ _ _ (hat.append hm)
+  · exact fun a t' hm => h2 a [] t' (.cons .nil hm)
+
+theorem Tree.evalChild_le_of : ∀ (l : List (Name × Tree)),
+    (∀ a t', (a, t') ∈ l → ∀ p t'', At t' p t'' →
+      evalPath ls ρ (p ++ [a]) (Node.eval ls ρ ⟨t''.const, t''.var⟩) ≤ m) →
+    (∀ a t', (a, t') ∈ l → ∀ b p t'', At t' (b :: p) t'' →
+      evalPath ls ρ ((b :: p) ++ [a]) (evalParam ls ρ b) ≤ m) →
+    (∀ a t', (a, t') ∈ l → evalPath ls ρ [a] (evalParam ls ρ a) ≤ m) →
+    evalChild ls ρ l ≤ m
+  | [], _, _, _ => by rw [evalChild]; exact Nat.zero_le _
+  | (a, t) :: l, h1, h2, h3 => by
+    rw [evalChild]
+    refine Nat.max_le.2 ⟨?_, evalChild_le_of l
+      (fun a t' hm => h1 a t' (.tail _ hm)) (fun a t' hm => h2 a t' (.tail _ hm))
+      (fun a t' hm => h3 a t' (.tail _ hm))⟩
+    by_cases ha : evalParam ls ρ a = 0
+    · simp [imax_eq_ite, ha]
+    · have hle : evalParam ls ρ a ≤ m := by
+        have := h3 a t (.head _)
+        simpa [evalPath, allNZ, Nat.pos_of_ne_zero ha] using this
+      have ht : eval ls ρ t ≤ m :=
+        eval_le_of t
+          (fun p t'' hat => evalPath_append_single ha ▸ h1 a t (.head _) p t'' hat)
+          (fun b p t'' hat => evalPath_append_single ha ▸ h2 a t (.head _) b p t'' hat)
+      rw [imax_eq_ite]; split <;> omega
 
-theorem geq'_wf (h : geq' u v)
-    (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') :
-    v' ≤ u' := by
-  intro ρ
-  rw [← Normalize.normalize_eval hv, ← Normalize.normalize_eval hu]
-  exact Normalize.NormLevel.le_eval h
-
-/- The verified comparison bridge closes over Lean's standard logical
-quotient/classical basis only.  In particular it does not inherit a project
-axiom or any of this repository's remaining sorry frontier. -/
-/--
-info: 'Lean.Level.Normalize.NormLevel.le_eval' depends on axioms: [propext, Classical.choice, Quot.sound]
+end
+
+/-- A tree is bounded by `m` exactly when all the sublevels it reifies to are: the ones
+recorded at its nodes, and the one each edge contributes. -/
+theorem Tree.eval_le_iff {t : Tree} {m : Nat} :
+    eval ls ρ t ≤ m ↔
+    (∀ p t', At t p t' → evalPath ls ρ p (Node.eval ls ρ ⟨t'.const, t'.var⟩) ≤ m) ∧
+    (∀ a p t', At t (a :: p) t' → evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ m) := by
+  refine ⟨fun h => ?_, fun ⟨h1, h2⟩ => eval_le_of t h1 h2⟩
+  refine ⟨fun _ t' hp => ?_, fun _ _ _ hp => Nat.le_trans hp.edge_le h⟩
+  exact Nat.le_trans (Nat.le_trans (evalPath_mono (eval_eq t' ▸ Nat.le_max_left ..)) hp.le) h
+
+/-!
+### Admissible chains
+
+Reifying the sublevels at a key `p` means nesting them under an `imax` chain whose variables
+are the elements of `p`; the chain contributes the sublevel `V(q, a, 0)` for every one of its
+edges, where `q` is the set of conditions from the outside up to and including that edge. The
+level is therefore equivalent to the normal form only if every such edge is *dominated*
+(`Dom`), and a key is expressible only if its elements can be ordered so that all of them are
+(`Feas`). `lexChain` searches for such an order greedily; `feasible` is its lookahead.
 -/
-#guard_msgs in
-#print axioms Normalize.NormLevel.le_eval
 
-/--
-info: 'Lean.Level.geq'_wf' depends on axioms: [propext, Classical.choice, Quot.sound]
+/-- The edge adding `a` to the conditions `acc` contributes `V(acc ∪ {a}, a, 0)`, which the
+normal form dominates when it has some `V(T, a+k)` with `T ⊆ acc ∪ {a}`. -/
+def NormLevel.Dom (s : NormLevel) (a : Name) (acc : List Name) : Prop :=
+  ∃ p n, s.get? p = some n ∧ (∃ x ∈ n.var, x.var = a) ∧ ∀ y ∈ p, y = a ∨ y ∈ acc
+
+theorem NormLevel.Dom.mono {s : NormLevel}
+    (h : s.Dom a acc) (hs : ∀ x ∈ acc, x ∈ acc') : s.Dom a acc' :=
+  let ⟨p, n, h1, h2, h3⟩ := h
+  ⟨p, n, h1, h2, fun y hy => (h3 y hy).imp id (hs _)⟩
+
+/-- A dominated edge contributes nothing beyond the normal form. -/
+theorem NormLevel.Dom.le {s : NormLevel} (h : s.Dom a acc) :
+    evalPath ls ρ (a :: acc) (evalParam ls ρ a) ≤ s.eval ls ρ := by
+  refine evalPath_le.2 fun nz => ?_
+  rw [allNZ_cons] at nz
+  obtain ⟨p, n, h1, ⟨x, hx, hxa⟩, h3⟩ := h
+  have hnz : allNZ ls ρ p := by
+    simp only [allNZ, List.all_eq_true, decide_eq_true_eq]
+    refine fun y hy => (h3 y hy).elim (fun e => e ▸ nz.1) fun hy => ?_
+    simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at nz
+    exact nz.2 _ hy
+  refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hx)
+    (evalPath_le.1 (NormLevel.eval_le.1 (Nat.le_refl _) _ _ h1) hnz))
+  simp only [VarNode.eval, ← hxa]; omega
+
+theorem NormLevel.addable_sound {s : NormLevel} (h : s.addable a acc) : s.Dom a acc := by
+  simp only [addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true, Bool.and_eq_true,
+    beq_iff_eq] at h
+  obtain ⟨⟨p, n⟩, hm, ⟨x, hx, hxa⟩, hsub⟩ := h
+  refine ⟨p, n, Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hm,
+    ⟨x, hx, hxa⟩, fun y hy => ?_⟩
+  by_cases hya : y = a
+  · exact .inl hya
+  · exact .inr (subset_mem hsub ((List.mem_erase_of_ne hya).2 hy))
+
+theorem NormLevel.addable_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p)
+    (hacc : Sorted acc) (h : s.Dom a acc) : s.addable a acc := by
+  obtain ⟨p, n, h1, ⟨x, hx, hxa⟩, h3⟩ := h
+  simp only [addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true, Bool.and_eq_true,
+    beq_iff_eq]
+  refine ⟨(p, n), Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (by simpa using h1),
+    ⟨x, hx, hxa⟩, subset_of_sorted (hs _ _ h1).erase hacc fun y hy => ?_⟩
+  refine (h3 y (List.mem_of_mem_erase hy)).resolve_left fun e => ?_
+  exact absurd (e ▸ hy) ((hs _ _ h1).nodup.not_mem_erase)
+
+/-- The conditions `rem` can be added to `acc` one at a time, each addition dominated. -/
+inductive NormLevel.Feas (s : NormLevel) : List Name → List Name → Prop
+  | nil {acc} : Feas s acc []
+  | cons {acc a rem} : a ∈ rem → s.Dom a acc → Feas s (a :: acc) (rem.erase a) → Feas s acc rem
+
+theorem NormLevel.Feas.mono {s : NormLevel} (hs : ∀ x ∈ acc, x ∈ acc')
+    (h : Feas s acc rem) : Feas s acc' rem := by
+  induction h generalizing acc' with | nil => exact .nil | cons hm hd _ ih
+  refine .cons hm (hd.mono hs) <| ih fun x hx => ?_
+  obtain rfl | hx := List.mem_cons.1 hx
+  · exact .head _
+  · exact .tail _ (hs _ hx)
+
+/-- Greedy exchange: a dominated element can always be taken first. -/
+theorem NormLevel.Feas.exchange {s : NormLevel} (h : Feas s acc rem) :
+    ∀ {a}, a ∈ rem → s.Dom a acc → Feas s (a :: acc) (rem.erase a) := by
+  induction h with | nil => nofun | @cons acc b rem hmb hdb H ih
+  intro a hm hd
+  by_cases hab : a = b <;> [(subst hab; exact H); skip]
+  refine .cons ((List.mem_erase_of_ne (Ne.symm hab)).2 hmb) (hdb.mono fun x hx => .tail _ hx) ?_
+  rw [List.erase_comm]
+  refine ih ((List.mem_erase_of_ne hab).2 hm) (hd.mono fun x hx => .tail _ hx)
+    |>.mono fun x hx => ?_
+  obtain rfl | hx := List.mem_cons.1 hx
+  · exact .tail _ (.head _)
+  · obtain rfl | hx := List.mem_cons.1 hx
+    · exact .head _
+    · exact .tail _ (.tail _ hx)
+
+/-- Peel off the element added last: it is dominated by all the others. -/
+theorem NormLevel.Feas.peel {s : NormLevel} (h : Feas s acc rem) (nd : rem.Nodup) (hne : rem ≠ []) :
+    ∃ a ∈ rem, s.Dom a (acc ++ rem.erase a) ∧ Feas s acc (rem.erase a) := by
+  induction h with
+  | nil => exact absurd rfl hne
+  | @cons acc b rem hmb hdb H ih =>
+    by_cases he : rem.erase b = []
+    · exact ⟨b, hmb, hdb.mono fun x hx => List.mem_append_left _ hx, he ▸ .nil⟩
+    obtain ⟨a, hma, hda, hfa⟩ := ih (nd.erase _) he
+    have hab : a ≠ b := by rintro rfl; exact absurd hma nd.not_mem_erase
+    have hmb' : b ∈ rem.erase a := (List.mem_erase_of_ne (Ne.symm hab)).2 hmb
+    refine ⟨a, List.mem_of_mem_erase hma, hda.mono fun x hx => ?_, ?_⟩
+    · simp only [List.cons_append, List.mem_cons, List.mem_append] at hx ⊢
+      obtain rfl | hx | hx := hx
+      · exact .inr hmb'
+      · exact .inl hx
+      · rw [List.erase_comm] at hx; exact .inr (List.mem_of_mem_erase hx)
+    · exact .cons hmb' hdb <| by rw [List.erase_comm]; exact hfa
+
+theorem NormLevel.feasible_go_sound {s : NormLevel} :
+    ∀ {fuel acc rem}, NormLevel.feasible.go s fuel acc rem → s.Feas acc rem
+  | 0, _, rem, h => by simp [feasible.go, List.isEmpty_iff] at h; exact h ▸ .nil
+  | fuel+1, acc, rem, h => by
+    rw [feasible.go] at h
+    split at h <;> [(let [] := rem; exact .nil); rename_i a ha]
+    have hm := List.mem_of_find?_eq_some ha
+    have hd := addable_sound (List.find?_eq_some_iff_getElem.1 ha).1
+    refine .cons hm hd ((feasible_go_sound h).mono fun x hx => ?_)
+    exact List.mem_cons.2 ((Extend?.orderedInsert (cmp := Name.cmp) (v := a) (p := acc)).mem.1 hx)
+
+theorem NormLevel.feasible_sound {s : NormLevel} (h : s.feasible acc rem) : s.Feas acc rem :=
+  feasible_go_sound h
+
+theorem NormLevel.feasible_go_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) :
+    ∀ {fuel acc rem}, rem.length ≤ fuel → Sorted acc → s.Feas acc rem → feasible.go s fuel acc rem
+  | 0, _, rem, hf, _, _ => by
+    rw [feasible.go]; cases rem with | nil => rfl | cons => cases hf
+  | fuel+1, acc, rem, hf, hacc, h => by
+    rw [feasible.go]
+    split <;> [rename_i ha; rename_i a ha]
+    · -- the first element of the chain is addable, so `find?` cannot fail
+      cases h with | nil => rfl | @cons b _ _ hm hd
+      exact absurd (addable_complete hs hacc hd) (by simpa using List.find?_eq_none.1 ha _ hm)
+    · have hm := List.mem_of_find?_eq_some ha
+      have hd := addable_sound (List.find?_eq_some_iff_getElem.1 ha).1
+      have hext := Extend?.orderedInsert (cmp := Name.cmp) (v := a) (p := acc)
+      refine feasible_go_complete hs ?_ ?_ ((h.exchange hm hd).mono fun x hx => hext.mem.2 ?_)
+      · rw [List.length_erase_of_mem hm]; omega
+      · match he : Normalize.orderedInsert Name.cmp a acc with
+        | none => exact hacc
+        | some acc' => exact hacc.orderedInsert he
+      · exact List.mem_cons.1 hx
+
+theorem NormLevel.feasible_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p)
+    (hacc : Sorted acc) (h : s.Feas acc rem) : s.feasible acc rem :=
+  feasible_go_complete hs (Nat.le_refl _) hacc h
+
+theorem NormLevel.Feas.perm {s : NormLevel} (h : Feas s acc rem) (hp : rem.Perm rem') :
+    Feas s acc rem' := by
+  induction h generalizing rem' with
+  | nil => cases hp.nil_eq; exact .nil
+  | cons hm hd _ ih => exact .cons (hp.mem_iff.1 hm) hd (ih (hp.erase _))
+
+/-- Extend a chain on the inside: the new element's conditions are all the others. -/
+theorem NormLevel.Feas.cons_last {s : NormLevel} (h : Feas s acc rem) (hnm : a ∉ rem)
+    (hd : s.Dom a (acc ++ rem)) : Feas s acc (a :: rem) := by
+  induction h with
+  | nil => exact .cons (.head _) (by simpa using hd) (by simpa using Feas.nil)
+  | @cons acc b rem hmb hdb _ ih =>
+    have hab : b ≠ a := fun e => hnm (e ▸ hmb)
+    refine .cons (.tail _ hmb) hdb ?_
+    rw [List.erase_cons_tail (by simpa using Ne.symm hab)]
+    refine ih (fun h => hnm (List.mem_of_mem_erase h)) (hd.mono fun x hx => ?_)
+    -- everything outside `a` is still there: `b` moved into the accumulator
+    simp only [List.cons_append, List.mem_cons, List.mem_append] at hx ⊢
+    obtain hx | hx := hx
+    · exact .inr (.inl hx)
+    · by_cases hxb : x = b
+      · exact .inl hxb
+      · exact .inr (.inr ((List.mem_erase_of_ne hxb).2 hx))
+
+/-- Every key of a well-formed normal form admits a chain: its `WF` parent is a key with one
+condition fewer, and the variable relating them dominates the edge between them. -/
+theorem NormLevel.WF.feas {s : NormLevel} (wf : s.WF) : ∀ {p}, s.contains p → s.Feas [] p := by
+  intro p
+  generalize eq : p.length = len
+  induction len generalizing p with
+  | zero => cases List.eq_nil_of_length_eq_zero eq; exact fun _ => .nil
+  | succ len ih =>
+    intro hp
+    have hne : p ≠ [] := by rintro rfl; cases eq
+    obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp)
+    obtain ⟨v, p', h1, h2, x, hx, hxv⟩ := (wf _ _ hn).1 hne
+    have hperm : p.Perm (v :: p') := by cases h1; exact List.perm_middle
+    have hnm : v ∉ p' := by
+      have := (wf.sortedOf (.inr hp)).nodup
+      rw [hperm.nodup_iff] at this
+      exact (List.nodup_cons.1 this).1
+    refine Feas.perm ?_ hperm.symm
+    refine Feas.cons_last (h2.elim (fun e => by subst e; exact .nil) (fun h => ih (by
+      have := h1.length; omega) h)) hnm ⟨p, n, hn, ⟨x, hx, hxv⟩, fun y hy => ?_⟩
+    simpa using (h1.mem.1 hy).imp id id
+
+/-- Domination only reads off variable names and their keys, so a map that covers another
+dominates whatever it does. -/
+theorem NormLevel.Dom.mono_map {s s' : NormLevel} (h : s'.Covers s) (hd : s.Dom a acc) :
+    s'.Dom a acc := by
+  obtain ⟨p, n, hp, ⟨x, hx, hxa⟩, hcond⟩ := hd
+  obtain ⟨q, m, y, hq, hy, e, hsub⟩ := h _ _ _ hp hx
+  exact ⟨q, m, hq, ⟨y, hy, e.trans hxa⟩, fun z hz => hcond _ (hsub _ hz)⟩
+
+theorem NormLevel.Feas.mono_map {s s' : NormLevel} (h : s'.Covers s) :
+    ∀ {acc rem}, s.Feas acc rem → s'.Feas acc rem
+  | _, _, .nil => .nil
+  | _, _, .cons hm hd H => .cons hm (hd.mono_map h) (Feas.mono_map h H)
+
+/-- Every key of the normal form admits a chain. `WF.feas` gives this for the map `normalizeAux`
+builds; subsumption keeps it because it covers that map, dropping a variable only in favour of
+one with the same name at a smaller key. -/
+theorem normalize_feas : ∀ p, (normalize u).contains p → (normalize u).Feas [] p := by
+  intro p hp
+  have wf : (normalizeAux u [] 0 {}).WF := normalizeAux_wf (by simp) (by simp [NormLevel.WF])
+  refine NormLevel.Feas.mono_map NormLevel.subsumption_covers.2 (wf.feas ?_)
+  obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp)
+  obtain ⟨n₀, h₀, -⟩ := NormLevel.subsumption_covers.1 p n
+    (by rw [Std.TreeMap.get?_eq_getElem?]; exact hn)
+  exact Std.TreeMap.isSome_getElem?_eq_contains.symm.trans
+    (by simp [Std.TreeMap.get?_eq_getElem?] at h₀; simp [h₀])
+
+/-- An admissible chain, innermost first: each element is dominated relative to the
+conditions outside it. -/
+def NormLevel.Adm (s : NormLevel) : List Name → Prop
+  | [] => True
+  | a :: l => s.Dom a l ∧ s.Adm l
+
+/-- `lexChain` always reorders its input, even in the fallback branch. -/
+theorem NormLevel.lexChain_perm {s : NormLevel} : ∀ {fuel p}, (s.lexChain fuel p).Perm p
+  | 0, p => by rw [lexChain]
+  | fuel+1, p => by
+    rw [lexChain]
+    split
+    · rename_i a ha
+      exact .trans (.cons _ lexChain_perm)
+        (List.perm_cons_erase (List.mem_of_find?_eq_some ha)).symm
+    · exact .refl _
+
+/-- Whenever a key admits some chain, `lexChain` returns one: it reorders the key, and
+every edge of the resulting `imax` chain is dominated. -/
+theorem NormLevel.lexChain_spec {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) :
+    ∀ {fuel p}, p.length ≤ fuel → Sorted p → s.Feas [] p →
+      (s.lexChain fuel p).Perm p ∧ s.Adm (s.lexChain fuel p)
+  | 0, p, hf, _, _ => by
+    rw [lexChain]; cases p with | nil => exact ⟨.refl _, trivial⟩ | cons => cases hf
+  | fuel+1, p, hf, hp, h => by
+    rw [lexChain]
+    split
+    · rename_i a ha
+      have hm := List.mem_of_find?_eq_some ha
+      have hpred := List.find?_eq_some_iff_getElem.1 ha |>.1
+      simp only [Bool.and_eq_true] at hpred
+      have hlen : (p.erase a).length ≤ fuel := by
+        rw [List.length_erase_of_mem hm]; omega
+      obtain ⟨hperm, hadm⟩ :=
+        lexChain_spec hs hlen hp.erase (feasible_sound hpred.2)
+      refine ⟨.trans (.cons _ hperm) (List.perm_cons_erase hm).symm, ?_, hadm⟩
+      exact (addable_sound hpred.1).mono fun x hx => hperm.mem_iff.2 hx
+    · rename_i hnone
+      -- the chain that exists ends somewhere, and `find?` would have found that element
+      refine ⟨.refl _, ?_⟩
+      match p, h with
+      | [], _ => exact trivial
+      | b :: p, h =>
+        obtain ⟨a, hm, hd, hfa⟩ := h.peel hp.nodup (by simp)
+        have h1 : s.addable a ((b :: p).erase a) :=
+          addable_complete hs hp.erase (by simpa using hd)
+        have h2 : s.feasible [] ((b :: p).erase a) := feasible_complete hs Sorted.nil hfa
+        have hnot := List.find?_eq_none.1 hnone _ hm
+        simp [h1, h2] at hnot
+
+theorem NormLevel.Adm.suffix {s : NormLevel} : ∀ {l}, s.Adm l → a :: q <:+ l → s.Dom a q
+  | [], _, h => by simp at h
+  | b :: l, ⟨h1, h2⟩, h => by
+    obtain ⟨l', he⟩ := h
+    match l' with
+    | [] => cases he; exact h1
+    | c :: l' => exact Adm.suffix h2 ⟨l', by cases he; rfl⟩
+
+/-! ### Building the tree -/
+
+theorem evalPath_le_self : evalPath ls ρ path c ≤ c := by rw [evalPath]; split <;> simp
+
+theorem evalPath_perm (h : p.Perm p') : evalPath ls ρ p c = evalPath ls ρ p' c := by
+  simp only [evalPath, show allNZ ls ρ p = allNZ ls ρ p' from Bool.eq_iff_iff.2
+    ⟨allNZ_mono fun _ hx => h.symm.mem_iff.1 hx, allNZ_mono fun _ hx => h.mem_iff.1 hx⟩]
+
+theorem evalPath_singleton :
+    evalPath ls ρ [a] c = if 0 < evalParam ls ρ a then c else 0 := by simp [evalPath, allNZ]
+
+theorem evalPath_single : evalPath ls ρ p (evalPath ls ρ [a] c) = evalPath ls ρ (a :: p) c := by
+  rw [evalPath_singleton, ← evalPath_cons]
+
+theorem imax_eq_evalPath : Lean.Nat.imax c (evalParam ls ρ a) =
+    max' (evalPath ls ρ [a] c) (evalPath ls ρ [a] (evalParam ls ρ a)) := by
+  by_cases h : evalParam ls ρ a = 0 <;>
+    simp [imax_eq_ite, evalPath_singleton, h, Nat.pos_of_ne_zero]
+
+/-- `modify` read from the outside in, matching the way `Tree.At` extends a path: the
+shallowest element of the path selects a child, and the rest is modified inside it. -/
+theorem Tree.modify_append (path : List Name) (g : Tree → Tree) (b : Name) (t : Tree) :
+    Tree.modify (path ++ [b]) g t =
+    { t with child := modifyAt (Tree.modify path g) b t.child } := by
+  induction path generalizing t g with
+  | nil => rfl
+  | cons a p ih => rw [List.cons_append, Tree.modify, ih]; rfl
+
+/-- All that matters about `modifyAt`: it replaces one entry with key `a` by `f` of it, or
+inserts `(a, f default)` somewhere if there is none, and leaves the rest of the list alone. -/
+theorem modifyAt_eq (f : Tree → Tree) (a : Name) (l : List (Name × Tree)) :
+    ∃ l₁ l₂ y, modifyAt f a l = l₁ ++ (a, f y) :: l₂ ∧
+      (l = l₁ ++ l₂ ∧ y = default ∨ l = l₁ ++ (a, y) :: l₂) := by
+  induction l with
+  | nil => exact ⟨[], [], default, rfl, .inl ⟨rfl, rfl⟩⟩
+  | cons b l ih =>
+    obtain ⟨b, t⟩ := b
+    match he : Name.cmp a b with
+    | .lt => exact ⟨[], (b, t) :: l, default, by simp [modifyAt, he], .inl ⟨rfl, rfl⟩⟩
+    | .eq =>
+      rw [Std.LawfulBEqCmp.compare_eq_iff_beq (cmp := Name.cmp)] at he
+      cases eq_of_beq he
+      exact ⟨[], l, t, by
+        simp [modifyAt, Std.ReflCmp.compare_self (cmp := Name.cmp)], .inr rfl⟩
+    | .gt =>
+      obtain ⟨l₁, l₂, y, h1, h2⟩ := ih
+      exact ⟨(b, t) :: l₁, l₂, y, by simp [modifyAt, he, h1],
+        h2.imp (fun ⟨h, hy⟩ => ⟨by simp [h], hy⟩) fun h => by simp [h]⟩
+
+theorem mem_modifyAt_self (f : Tree → Tree) (a : Name) (l : List (Name × Tree)) :
+    ∃ y, (a, f y) ∈ modifyAt f a l := by
+  obtain ⟨l₁, l₂, y, h, -⟩ := modifyAt_eq f a l
+  exact ⟨y, by rw [h]; simp⟩
+
+/-- The node `modify` writes is there to be found, and its data does not depend on what was
+at the path before: the payload of a key is what sits at the end of its chain. -/
+theorem Tree.At_modify_self (path : List Name) (g : Tree → Tree) (t : Tree) :
+    ∃ t₀, Tree.At (t.modify path g) path (g t₀) := by
+  suffices ∀ (r : List Name) (g : Tree → Tree) (t : Tree),
+      ∃ t₀, Tree.At (Tree.modify r.reverse g t) r.reverse (g t₀) by
+    simpa using this path.reverse g t
+  clear path g t; intro r
+  induction r with
+  | nil => exact fun g t => ⟨t, .nil⟩
+  | cons b r ih =>
+    intro g t
+    rw [List.reverse_cons, Tree.modify_append]
+    obtain ⟨x, hx⟩ := mem_modifyAt_self (f := Tree.modify r.reverse g) b t.child
+    obtain ⟨t₀, ht₀⟩ := ih g x
+    exact ⟨t₀, ht₀.append hx⟩
+
+/-- Nothing is lost: an entry either survives `modifyAt` untouched, or is the one it modifies.
+(The second case does not need the entry to be the *first* one with its key, so no
+duplicate-freedom assumption is needed here or below.) -/
+theorem mem_modifyAt {f : Tree → Tree} {l : List (Name × Tree)} (hm : (c, x) ∈ l) :
+    (c, x) ∈ modifyAt f a l ∨ (c = a ∧ (c, f x) ∈ modifyAt f a l) := by
+  obtain ⟨l₁, l₂, y, h, h'⟩ := modifyAt_eq f a l
+  rw [h]
+  obtain ⟨rfl, -⟩ | rfl := h'
+  · obtain hm | hm := List.mem_append.1 hm
+    · exact .inl (List.mem_append.2 (.inl hm))
+    · exact .inl (List.mem_append.2 (.inr (.tail _ hm)))
+  · obtain hm | hm := List.mem_append.1 hm
+    · exact .inl (List.mem_append.2 (.inl hm))
+    obtain heq | hm := List.mem_cons.1 hm
+    · simp only [Prod.mk.injEq] at heq; obtain ⟨rfl, rfl⟩ := heq
+      exact .inr ⟨rfl, List.mem_append.2 (.inr (.head _))⟩
+    · exact .inl (List.mem_append.2 (.inr (.tail _ hm)))
+
+/-- A node written at one path survives a later write at a different path: the write only
+replaces the data of the node it lands on, and every other node keeps its own. -/
+theorem Tree.At_modify_of_ne_aux {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) :
+    ∀ (r : List Name) {path t t'}, path ≠ r.reverse → At t path t' →
+      ∃ t'', At (Tree.modify r.reverse g t) path t'' ∧
+        t''.const = t'.const ∧ t''.var = t'.var := by
+  intro r
+  induction r with
+  | nil =>
+    intro path t t' hne h
+    rw [List.reverse_nil, Tree.modify]
+    obtain h' | ⟨rfl, rfl⟩ := h.of_child_eq (hg t)
+    · exact ⟨t', h', rfl, rfl⟩
+    · exact absurd rfl hne
+  | cons b r ih =>
+    intro path t t' hne h
+    rw [List.reverse_cons, Tree.modify_append]
+    obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat path
+    · cases h.nil_inv; exact ⟨_, .nil, rfl, rfl⟩
+    simp only [List.concat_eq_append, List.reverse_cons] at h hne ⊢
+    obtain ⟨t₁, hm, h₁⟩ := h.append_inv
+    obtain hm' | ⟨rfl, hm'⟩ := mem_modifyAt (f := Tree.modify r.reverse g) (a := b) hm
+    · exact ⟨t', h₁.append hm', rfl, rfl⟩
+    · have : q ≠ r.reverse := by rintro rfl; exact hne rfl
+      obtain ⟨t'', h'', hc, hv⟩ := ih this h₁
+      exact ⟨t'', h''.append hm', hc, hv⟩
+
+theorem Tree.At_modify_of_ne {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child)
+    (hne : path ≠ path') (h : At t path t') :
+    ∃ t'', At (Tree.modify path' g t) path t'' ∧ t''.const = t'.const ∧ t''.var = t'.var := by
+  have := At_modify_of_ne_aux hg path'.reverse (path := path) (by rwa [List.reverse_reverse]) h
+  rwa [List.reverse_reverse] at this
+
+/-- Conversely, nothing appears from nowhere: an entry of `modifyAt` is an entry of the list,
+or the modified one, which was an entry or is fresh. -/
+theorem mem_modifyAt_inv {f : Tree → Tree} {l : List (Name × Tree)}
+    (h : (c, x) ∈ modifyAt f a l) :
+    (c, x) ∈ l ∨ (c = a ∧ ∃ y, x = f y ∧ (y = default ∨ (a, y) ∈ l)) := by
+  induction l with
+  | nil =>
+    simp only [modifyAt, List.mem_singleton, Prod.mk.injEq] at h
+    obtain ⟨rfl, rfl⟩ := h
+    exact .inr ⟨rfl, default, rfl, .inl rfl⟩
+  | cons b l ih =>
+    obtain ⟨b, t⟩ := b
+    match he : Name.cmp a b with
+    | .lt =>
+      simp only [modifyAt, he] at h
+      obtain h | h := List.mem_cons.1 h
+      · cases h; exact .inr ⟨rfl, default, rfl, .inl rfl⟩
+      · exact .inl h
+    | .eq =>
+      rw [Std.LawfulBEqCmp.compare_eq_iff_beq (cmp := Name.cmp)] at he
+      cases eq_of_beq he
+      simp only [modifyAt, Std.ReflCmp.compare_self (cmp := Name.cmp)] at h
+      obtain h | h := List.mem_cons.1 h
+      · cases h; exact .inr ⟨rfl, t, rfl, .inr (.head _)⟩
+      · exact .inl (.tail _ h)
+    | .gt =>
+      simp only [modifyAt, he] at h
+      obtain h | h := List.mem_cons.1 h
+      · cases h; exact .inl (.head _)
+      · exact (ih h).imp (.tail _) fun ⟨rfl, y, hy, h⟩ => ⟨rfl, y, hy, h.imp id (.tail _)⟩
+
+theorem Tree.At.of_child_nil (hc : t.child = []) (h : At t p t') : p = [] ∧ t' = t := by
+  obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat p
+  · exact ⟨rfl, h.nil_inv⟩
+  · rw [List.concat_eq_append] at h
+    obtain ⟨t₁, hm, -⟩ := h.append_inv
+    rw [hc] at hm; cases hm
+
+theorem suffix_concat {α} {l₁ l₂ : List α} (h : l₁ <:+ l₂) (a : α) :
+    l₁ ++ [a] <:+ l₂ ++ [a] := by
+  obtain ⟨u, rfl⟩ := h; exact ⟨u, by rw [List.append_assoc]⟩
+
+/-- Inverting a write: a path of the modified tree either ends at the node just written, or
+is a tail of the written path whose node was created empty on the way, or was already there
+carrying the same data. -/
+theorem Tree.At_modify_inv_aux {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) :
+    ∀ (r : List Name) {path t t'}, At (Tree.modify r.reverse g t) path t' →
+      (path = r.reverse ∧ ∃ t₀, t' = g t₀) ∨
+      (path <:+ r.reverse ∧ t'.const = 0 ∧ t'.var = []) ∨
+      (∃ t'', At t path t'' ∧ t'.const = t''.const ∧ t'.var = t''.var) := by
+  intro r
+  induction r with
+  | nil =>
+    intro path t t' h
+    rw [List.reverse_nil, Tree.modify] at h
+    obtain h' | ⟨rfl, rfl⟩ := h.of_child_eq (hg t).symm
+    · exact .inr (.inr ⟨t', h', rfl, rfl⟩)
+    · exact .inl ⟨rfl, t, rfl⟩
+  | cons b r ih =>
+    intro path t t' h
+    rw [List.reverse_cons, Tree.modify_append] at h
+    obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat path
+    · cases h.nil_inv; exact .inr (.inr ⟨t, .nil, rfl, rfl⟩)
+    rw [List.concat_eq_append] at h ⊢
+    obtain ⟨t₁, hm, h₁⟩ := h.append_inv
+    obtain hm | ⟨rfl, y, rfl, hy⟩ := mem_modifyAt_inv hm
+    · exact .inr (.inr ⟨t', h₁.append hm, rfl, rfl⟩)
+    · obtain ⟨rfl, t₀, rfl⟩ | ⟨hs, hc, hv⟩ | ⟨t'', h'', hc, hv⟩ := ih h₁
+      · exact .inl ⟨by rw [List.reverse_cons], t₀, rfl⟩
+      · exact .inr (.inl ⟨by rw [List.reverse_cons]; exact suffix_concat hs _, hc, hv⟩)
+      · obtain rfl | hy := hy
+        · obtain ⟨rfl, rfl⟩ := h''.of_child_nil rfl
+          exact .inr (.inl ⟨by rw [List.reverse_cons]; exact ⟨r.reverse, by simp⟩, hc, hv⟩)
+        · exact .inr (.inr ⟨t'', h''.append hy, hc, hv⟩)
+
+theorem Tree.At_modify_inv {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child)
+    (h : At (Tree.modify path' g t) path t') :
+    (path = path' ∧ ∃ t₀, t' = g t₀) ∨
+    (path <:+ path' ∧ t'.const = 0 ∧ t'.var = []) ∨
+    (∃ t'', At t path t'' ∧ t'.const = t''.const ∧ t'.var = t''.var) := by
+  have := At_modify_inv_aux hg path'.reverse (path := path)
+    (by rwa [List.reverse_reverse]) (t' := t')
+  rwa [List.reverse_reverse] at this
+
+/-- Sorted lists with the same elements are equal, so distinct keys reify to distinct paths:
+`lexChain` only permutes a key. -/
+theorem Sorted.perm_eq (h₁ : Sorted l₁) (h₂ : Sorted l₂) (h : l₁.Perm l₂) : l₁ = l₂ := by
+  induction l₁ generalizing l₂ with
+  | nil => exact h.nil_eq
+  | cons a l₁ ih =>
+    match l₂, h₂, h with
+    | [], _, h => simp at h
+    | b :: l₂, h₂, h =>
+      have hab : a = b := by
+        -- each head is at most every element of the other list
+        obtain rfl | ha := List.mem_cons.1 (h.mem_iff.1 (.head _))
+        · rfl
+        obtain rfl | hb := List.mem_cons.1 (h.symm.mem_iff.1 (.head _))
+        · rfl
+        exact absurd (h₂.head _ ha) (by
+          rw [Std.OrientedCmp.gt_of_lt (h₁.head _ hb)]; simp)
+      subst hab
+      rw [ih h₁.of_cons h₂.of_cons ((List.perm_cons _).1 h)]
+
+/-- The variables the reconstruction records for the entry `(p, n)`: those of `n`, except the
+one the edge into the node already contributes. -/
+def NormLevel.treeVar (s : NormLevel) (p : List Name) (n : Node) : List VarNode :=
+  if let v :: _ := s.lexChain p.length p then subsumeVars n.var [⟨v, 0⟩] else n.var
+
+/-- The entry `(p, n)` is recorded in `t`: at the end of `p`'s chain sits a node carrying
+`n`'s constant and `treeVar p n`. -/
+def NormLevel.WrittenAt (s : NormLevel) (t : Tree) (p : List Name) (n : Node) : Prop :=
+  ∃ t', Tree.At t (s.lexChain p.length p) t' ∧ t'.const = n.const ∧ t'.var = s.treeVar p n
+
+theorem NormLevel.WrittenAt.write {s : NormLevel} (t : Tree) (p : List Name) (n : Node) :
+    s.WrittenAt (t.modify (s.lexChain p.length p)
+      fun t => { t with const := n.const, var := s.treeVar p n }) p n :=
+  let ⟨_, h⟩ := Tree.At_modify_self _ _ t
+  ⟨_, h, rfl, rfl⟩
+
+/-- Distinct keys get distinct chains, since `lexChain` only permutes a sorted key. -/
+theorem NormLevel.lexChain_inj {s : NormLevel} (h₁ : Sorted p) (h₂ : Sorted p')
+    (h : s.lexChain p.length p = s.lexChain p'.length p') : p = p' := by
+  refine Sorted.perm_eq h₁ h₂ ((lexChain_perm (s := s) (fuel := p.length) (p := p)).symm.trans ?_)
+  rw [h]; exact lexChain_perm
+
+/-- Conversely, everything the tree contains comes from an entry: every nonempty path is a
+tail of some key's chain, and the node at the end of a path is either empty scaffolding or
+the entry whose chain leads there. -/
+def NormLevel.Accounted (s : NormLevel) (t : Tree) : Prop :=
+  ∀ path t', Tree.At t path t' →
+    (path ≠ [] → ∃ p n, s.get? p = some n ∧ path <:+ s.lexChain p.length p) ∧
+    (t'.const = 0 ∧ t'.var = [] ∨ ∃ p n, s.get? p = some n ∧
+      path = s.lexChain p.length p ∧ t'.const = n.const ∧ t'.var = s.treeVar p n)
+
+/-- The single pass over the map that both directions of soundness read off: after the fold
+every entry is recorded at the end of its chain, and everything in the tree is accounted for
+by an entry. A write puts its own entry there (`At_modify_self`) and leaves the others alone,
+either because it lands on a different path — distinct keys have distinct chains — or because
+it lands on the same key, and then writes the same data. -/
+theorem NormLevel.toTree_spec {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p) :
+    s.Accounted (toTree s) ∧ ∀ p n, s.get? p = some n → s.WrittenAt (toTree s) p n := by
+  rw [toTree, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem : ∀ pn : List Name × Node, pn ∈ s.toList ↔ s.get? pn.1 = some pn.2 := fun _ =>
+    Std.TreeMap.mem_toList_iff_getElem?_eq_some.trans (by rw [Std.TreeMap.get?_eq_getElem?])
+  have hinit : s.Accounted ⟨0, [], []⟩ := fun path t' h => by
+    obtain ⟨rfl, rfl⟩ := h.of_child_nil rfl
+    exact ⟨fun h => absurd rfl h, .inl ⟨rfl, rfl⟩⟩
+  suffices ∀ (l : List (List Name × Node)) (t : Tree),
+      (∀ pn ∈ l, s.get? pn.1 = some pn.2) → s.Accounted t →
+      s.Accounted (List.foldl (fun t pn =>
+        let path := s.lexChain pn.1.length pn.1
+        let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var
+        t.modify path fun t => { t with const := pn.2.const, var }) t l) ∧
+      ∀ p n, s.get? p = some n → (s.WrittenAt t p n ∨ (p, n) ∈ l) →
+      s.WrittenAt (List.foldl (fun t pn =>
+        let path := s.lexChain pn.1.length pn.1
+        let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var
+        t.modify path fun t => { t with const := pn.2.const, var }) t l) p n by
+    have := this _ _ (fun pn h => (hmem pn).1 h) hinit
+    exact ⟨this.1, fun p n hp => this.2 p n hp (.inr ((hmem (p, n)).2 hp))⟩
+  clear hmem hinit; intro l
+  induction l with
+  | nil => exact fun _ _ h => ⟨h, fun _ _ _ h => h.resolve_right (by simp)⟩
+  | cons pn l ih =>
+    obtain ⟨p', n'⟩ := pn
+    intro t hl hacc
+    have hp' : s.get? p' = some n' := hl _ (.head _)
+    refine (ih _ (fun _ h => hl _ (.tail _ h)) ?_).imp id fun H p n hp h => H p n hp ?_
+    · -- nothing unaccounted for appears: the write adds its own node and empty scaffolding
+      intro path t' h
+      obtain ⟨rfl, t₀, rfl⟩ | ⟨hs, hc, hv⟩ | ⟨t'', h'', hc, hv⟩ :=
+        Tree.At_modify_inv (g := fun t =>
+          { t with const := n'.const, var := s.treeVar p' n' }) (fun _ => rfl) h
+      · exact ⟨fun _ => ⟨p', n', hp', List.suffix_refl _⟩, .inr ⟨p', n', hp', rfl, rfl, rfl⟩⟩
+      · exact ⟨fun _ => ⟨p', n', hp', hs⟩, .inl ⟨hc, hv⟩⟩
+      · exact ⟨(hacc _ _ h'').1, by rw [hc, hv]; exact (hacc _ _ h'').2⟩
+    · -- and nothing already written is lost
+      obtain ⟨t', hat, hc, hv⟩ | h := h
+      · refine .inl ?_
+        by_cases hpp : p = p'
+        · subst hpp; cases hp.symm.trans hp'; exact .write ..
+        · obtain ⟨t'', hat', hc', hv'⟩ := Tree.At_modify_of_ne (g := fun t =>
+            { t with const := n'.const, var := s.treeVar p' n' }) (fun _ => rfl)
+            (fun he => hpp (lexChain_inj (hsort _ _ hp) (hsort _ _ hp') he)) hat
+          exact ⟨t'', hat', hc' ▸ hc, hv' ▸ hv⟩
+      · obtain h | h := List.mem_cons.1 h
+        · simp only [Prod.mk.injEq] at h
+          obtain ⟨rfl, rfl⟩ := h
+          exact .inl (.write ..)
+        · exact .inr h
+
+/-- What the reconstruction contributes, as a biconditional: the tree is bounded by `m`
+exactly when for every entry the node the tree records for it is, and so is every edge of its
+chain. Nothing here is about domination, so no hypothesis on the chains is needed. -/
+theorem NormLevel.toTree_le_iff {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p)
+    {m : Nat} : Tree.eval ls ρ (toTree s) ≤ m ↔
+      ∀ p n, s.get? p = some n →
+        evalPath ls ρ (s.lexChain p.length p) (Node.eval ls ρ ⟨n.const, s.treeVar p n⟩) ≤ m ∧
+        ∀ a q, a :: q <:+ s.lexChain p.length p →
+          evalPath ls ρ (a :: q) (evalParam ls ρ a) ≤ m := by
+  obtain ⟨hacc, hwr⟩ := toTree_spec hsort
+  rw [Tree.eval_le_iff]
+  refine ⟨fun ⟨h1, h2⟩ p n hp => ?_, fun H => ⟨fun path t' hat => ?_, fun a q t' hat => ?_⟩⟩
+  · obtain ⟨t', hat, hc, hv⟩ := hwr p n hp
+    refine ⟨by rw [← hc, ← hv]; exact h1 _ _ hat, fun a q hq => ?_⟩
+    obtain ⟨t'', hat''⟩ := hat.suffix hq
+    exact h2 _ _ _ hat''
+  · obtain ⟨-, ⟨hc, hv⟩ | ⟨p, n, hp, rfl, hc, hv⟩⟩ := hacc _ _ hat
+    · rw [show Node.eval ls ρ ⟨t'.const, t'.var⟩ = 0 from by simp [Node.eval, hc, hv]]
+      simp [evalPath]
+    · rw [hc, hv]; exact (H p n hp).1
+  · obtain ⟨p, n, hp, hsuf⟩ := (hacc _ _ hat).1 (by simp)
+    exact (H p n hp).2 _ _ hsuf
+
+/-- Soundness of the reconstruction: the tree built from a normal form, hence the level it
+reifies to, evaluates like the normal form. Below, because the node recorded for an entry
+carries a subset of its sublevels and every edge is dominated, `lexChain` emitting only
+admissible chains; above, because the one sublevel the node omits, `V(p, v, 0)` for the
+innermost element of the chain, is what the edge into it contributes. -/
+theorem NormLevel.toTree_eval {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p)
+    (hfeas : ∀ p, s.contains p → s.Feas [] p) :
+    Tree.eval ls ρ (toTree s) = s.eval ls ρ := by
+  refine ext_le fun m => (toTree_le_iff hsort).trans (Iff.trans ?_ NormLevel.eval_le.symm)
+  refine ⟨fun H p n hp => ?_, fun H p n hp => ⟨?_, fun a q hq => ?_⟩⟩
+  · -- the entry is the node the tree records for it, plus the edge into that node
+    rw [← evalPath_perm (lexChain_perm (s := s) (fuel := p.length) (p := p))]
+    refine evalPath_le.2 fun nz => ?_
+    have h1 := evalPath_le.1 (H p n hp).1 nz
+    rw [Node.eval_le] at h1 ⊢
+    refine ⟨h1.1, ?_⟩
+    rw [NormLevel.treeVar] at h1
+    split at h1
+    · rename_i v q hch
+      refine (subsumeVars_eval ?_).1 h1.2
+      simp only [List.mem_singleton, VarNode.eval]
+      rintro _ rfl
+      exact evalPath_le.1 ((H p n hp).2 v q (by rw [hch]; exact List.suffix_refl _)) (hch ▸ nz)
+    · exact h1.2
+  · -- the recorded node is part of the entry
+    rw [evalPath_perm (lexChain_perm (s := s) (fuel := p.length) (p := p))]
+    refine Nat.le_trans (evalPath_mono ?_) (H p n hp)
+    refine Node.eval_le.2 ⟨Node.const_le_eval (l := n), fun v hv => Node.var_le_eval ?_⟩
+    revert hv; rw [NormLevel.treeVar]; split
+    · exact subsumeVars_subset
+    · exact id
+  · -- and every edge of the chain is dominated by an entry
+    have hcon : s.contains p := Std.TreeMap.isSome_getElem?_eq_contains.symm.trans
+      (by simp [Std.TreeMap.get?_eq_getElem?] at hp; simp [hp])
+    obtain ⟨-, hadm⟩ := lexChain_spec hsort (Nat.le_refl _) (hsort _ _ hp) (hfeas _ hcon)
+    exact Nat.le_trans (hadm.suffix hq).le (NormLevel.eval_le.2 H)
+
+/-!
+### Completeness
+
+`geq'` and `isEquiv'` are not only sound but complete: `NormLevel.le` detects every semantic
+inequality between normal forms, and semantically equal levels have equal normal forms. The
+key is a converse to Theorem 39 (`NormLevel.le_eval`): evaluating at a valuation tailored to
+a single sublevel shows that a semantic bound forces a syntactic dominator among the
+sublevels of the bounding form (`separation`). Completeness of `le` then follows because the
+`subsumeBy` fold removes exactly the dominated sublevels, and canonicity because
+`subsumption` leaves no sublevel dominated by another slot (`Reduced`), so mutual domination
+forces the two maps to be equal.
 -/
-#guard_msgs in
-#print axioms geq'_wf
+
+/-- The variable lists of nodes are strictly sorted by variable name. -/
+def VarsSorted (l : List VarNode) : Prop := l.Pairwise (compare ·.var ·.var = .lt)
+
+theorem VarsSorted.of_cons (h : VarsSorted (v :: l)) : VarsSorted l := (List.pairwise_cons.1 h).2
+
+theorem VarsSorted.head (h : VarsSorted (v :: l)) : ∀ x ∈ l, compare v.var x.var = .lt :=
+  (List.pairwise_cons.1 h).1
+
+/-- In a sorted variable list, the name determines the entry. -/
+theorem VarsSorted.eq_of_var_eq (h : VarsSorted l) (h₁ : x ∈ l) (h₂ : y ∈ l)
+    (e : x.var = y.var) : x = y := by
+  induction l with | nil => cases h₁ | cons v l ih
+  obtain rfl | h₁' := List.mem_cons.1 h₁
+  · obtain rfl | h₂' := List.mem_cons.1 h₂
+    · rfl
+    · have := h.head _ h₂'; rw [e, Std.ReflOrd.compare_self] at this; cases this
+  · obtain rfl | h₂' := List.mem_cons.1 h₂
+    · have := h.head _ h₁'; rw [← e, Std.ReflOrd.compare_self] at this; cases this
+    · exact ih h.of_cons h₁' h₂'
+
+theorem VarNode.mem_addVar' (h : x ∈ VarNode.addVar v k l) : x.var = v ∨ x ∈ l := by
+  induction l with
+  | nil => simp [addVar] at h; simp [h]
+  | cons y l ih =>
+    simp only [addVar] at h
+    split at h
+    · rcases List.mem_cons.1 h with rfl | h <;> simp [h]
+    · rcases List.mem_cons.1 h with rfl | h <;> simp [h]
+    · rcases List.mem_cons.1 h with rfl | h
+      · simp
+      · exact (ih h).imp_right (.tail _)
+
+theorem VarNode.addVar_sorted (h : VarsSorted l) : VarsSorted (VarNode.addVar v k l) := by
+  induction l with | nil => exact .cons (by simp) .nil | cons x l ih
+  simp only [addVar]
+  split <;> rename_i hc
+  · refine .cons (fun y hy => ?_) h
+    obtain rfl | hy := List.mem_cons.1 hy
+    · exact hc
+    · exact Std.TransCmp.lt_trans hc (h.head _ hy)
+  · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at hc
+    have e := eq_of_beq hc
+    exact .cons (fun y hy => by rw [e]; exact h.head _ hy) h.of_cons
+  · refine .cons (fun y hy => ?_) (ih h.of_cons)
+    obtain e | hy := VarNode.mem_addVar' hy
+    · rw [e]; exact Std.OrientedCmp.lt_of_gt hc
+    · exact h.head _ hy
+
+/-- Every node of the map has its variable list sorted by name. -/
+def NormLevel.SortedVars (s : NormLevel) : Prop :=
+  ∀ p n, s.get? p = some n → VarsSorted n.var
+
+theorem NormLevel.addVar_sortedVars (h : acc.SortedVars) :
+    (addVar v k path acc).SortedVars := by
+  intro p n hn
+  simp only [addVar, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_modify] at hn
+  split at hn
+  · obtain ⟨n', hn', rfl⟩ := Option.map_eq_some_iff.1 hn
+    exact VarNode.addVar_sorted (h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ hn'))
+  · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn)
+
+theorem NormLevel.addNode_sortedVars (h : acc.SortedVars) :
+    (addNode v k path acc).SortedVars := by
+  intro p n hn
+  simp only [addNode, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn
+  split at hn
+  · match e : acc[path]?, hn with
+    | some n', hn =>
+      cases hn; exact VarNode.addVar_sorted (h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ e))
+    | none, hn => cases hn; exact .cons (by simp) .nil
+  · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn)
+
+theorem NormLevel.addConst_sortedVars (h : acc.SortedVars) :
+    (addConst k path acc).SortedVars := by
+  intro p n hn
+  simp only [addConst] at hn; split at hn <;> [exact h _ _ hn; skip]
+  simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn
+  split at hn
+  · match e : acc[path]?, hn with
+    | some n', hn => cases hn; exact h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ e)
+    | none, hn => cases hn; exact .nil
+  · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn)
+
+theorem normalizeAux_sortedVars (h : acc.SortedVars) :
+    (normalizeAux u path k acc).SortedVars := by
+  unfold normalizeAux; split
+  · exact NormLevel.addConst_sortedVars h
+  · exact NormLevel.addConst_sortedVars h
+  · exact normalizeAux_sortedVars h
+  · exact normalizeAux_sortedVars (normalizeAux_sortedVars h)
+  · exact normalizeAux_sortedVars (normalizeAux_sortedVars h)
+  · exact normalizeAux_sortedVars (normalizeAux_sortedVars h)
+  · exact normalizeAux_sortedVars (normalizeAux_sortedVars h)
+  · split <;> [skip; (dsimp; split)]
+    · exact normalizeAux_sortedVars
+        (NormLevel.addNode_sortedVars (NormLevel.addConst_sortedVars h))
+    · exact normalizeAux_sortedVars h
+    · exact normalizeAux_sortedVars (NormLevel.addVar_sortedVars h)
+  · exact h
+  · exact h
+  · split <;> [skip; split]
+    · exact NormLevel.addNode_sortedVars (NormLevel.addConst_sortedVars h)
+    · exact h
+    · exact NormLevel.addVar_sortedVars h
+
+theorem subsumeVars_sublist : ∀ vs₁ vs₂ : List VarNode, List.Sublist (subsumeVars vs₁ vs₂) vs₁
+  | [], _ => by simp [subsumeVars]
+  | _ :: _, [] => by simp [subsumeVars]
+  | x :: xs, y :: ys => by
+    simp only [subsumeVars]; split
+    · exact (subsumeVars_sublist xs (y :: ys)).cons_cons x
+    · split
+      · exact (subsumeVars_sublist xs ys).cons x
+      · exact (subsumeVars_sublist xs ys).cons_cons x
+    · exact subsumeVars_sublist (x :: xs) ys
+
+theorem Node.subsume_var_sublist : List.Sublist (Node.subsume p₁ n₁ p₂ n₂).var n₁.var := by
+  obtain h | ⟨-, -, h⟩ := Node.subsume_var_cases p₁ n₁ p₂ n₂ <;> rw [h]
+  · exact List.Sublist.refl _
+  · exact subsumeVars_sublist ..
+
+theorem NormLevel.minimize_var_sublist {acc : NormLevel} :
+    List.Sublist (acc.minimize p₁ n₁).var n₁.var := by
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList]
+  generalize acc.toList = l
+  induction l generalizing n₁ with | nil => exact List.Sublist.refl _ | cons a l ih
+  exact (ih (n₁ := Node.subsume p₁ n₁ a.1 a.2)).trans Node.subsume_var_sublist
+
+theorem NormLevel.subsumption_sortedVars {s : NormLevel} (hs : s.SortedVars) :
+    s.subsumption.SortedVars := by
+  rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  generalize s.toList = l at hmem
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (∀ pn ∈ l, s.get? pn.1 = some pn.2) → acc.SortedVars →
+      ∀ p n, (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n →
+        VarsSorted n.var from this _ _ hmem hs
+  clear hmem; intro l
+  induction l with | nil => exact fun _ _ => id | cons pn l ih
+  intro acc hl hacc
+  refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h => ?_
+  rw [subsumption_step_get?] at h
+  split at h
+  · split at h <;> [cases h; skip]
+    cases h; rename_i hp _; subst hp
+    exact (hs _ _ (hl _ (.head _))).sublist minimize_var_sublist
+  · exact hacc _ _ h
+
+theorem normalize_sortedVars : (normalize u).SortedVars :=
+  NormLevel.subsumption_sortedVars (normalizeAux_sortedVars fun p n h => by simp at h)
+
+/-- `subsumption` erases a key rather than leaving an empty node behind. -/
+theorem NormLevel.subsumption_nonempty {s : NormLevel} :
+    ∀ p n, s.subsumption.get? p = some n → n.isEmpty = false := by
+  rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (∀ p n, acc.get? p = some n → n.isEmpty = false ∨ (p, n) ∈ l) →
+      ∀ p n, (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n →
+        n.isEmpty = false from
+    this _ _ fun p n h => .inr (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2
+      (Std.TreeMap.get?_eq_getElem? .. ▸ h))
+  intro l
+  induction l with
+  | nil => exact fun acc h p n hn => (h p n hn).resolve_right (by simp)
+  | cons pn l ih =>
+    intro acc hacc
+    refine ih _ fun p n h => ?_
+    rw [subsumption_step_get?] at h
+    split at h <;> rename_i hp
+    · split at h <;> [cases h; skip]
+      cases h; rename_i he; exact .inl (by simpa using he)
+    · refine (hacc _ _ h).imp_right fun hm => ?_
+      obtain h' | h' := List.mem_cons.1 hm
+      · exact absurd (congrArg Prod.fst h'.symm) hp
+      · exact h'
+
+theorem normalize_nonempty : ∀ p n, (normalize u).get? p = some n → n.isEmpty = false :=
+  NormLevel.subsumption_nonempty
+
+theorem NormLevel.addVar_keys (h : (addVar v k path acc).contains p) : acc.contains p := by
+  simpa [addVar, Std.TreeMap.mem_modify] using h
+
+theorem NormLevel.addNode_keys (h : (addNode v k path acc).contains p) :
+    p = path ∨ acc.contains p := by
+  rw [addNode, Std.TreeMap.contains_alter] at h
+  split at h
+  · rename_i hc
+    exact .inl (eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc)).symm
+  · exact .inr h
+
+theorem NormLevel.addConst_keys (h : (addConst k path acc).contains p) :
+    p = path ∨ acc.contains p := by
+  rw [addConst] at h; split at h <;> [exact .inr h; skip]
+  rw [Std.TreeMap.contains_alter] at h
+  split at h
+  · rename_i hc
+    exact .inl (eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc)).symm
+  · exact .inr h
+
+/-- All keys of the map built by `normalizeAux` consist of level parameters, which are
+in `ls` whenever `ofLevel` succeeds. -/
+theorem normalizeAux_keys (hu : VLevel.ofLevel ls u = some u')
+    (hpath : ∀ x ∈ path, x ∈ ls) (hacc : ∀ p, acc.contains p → ∀ x ∈ p, x ∈ ls) :
+    ∀ p, (normalizeAux u path k acc).contains p → ∀ x ∈ p, x ∈ ls := by
+  unfold normalizeAux; split
+  · exact fun p h => (NormLevel.addConst_keys h).elim
+      (fun e x hx => hpath x (e ▸ hx)) (hacc p)
+  · exact fun p h => (NormLevel.addConst_keys h).elim
+      (fun e x hx => hpath x (e ▸ hx)) (hacc p)
+  · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu
+    exact normalizeAux_keys hu hpath hacc
+  · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu
+    exact normalizeAux_keys hv hpath (normalizeAux_keys hu hpath hacc)
+  · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, rfl⟩, rfl⟩ := hu
+    exact normalizeAux_keys hv hpath (normalizeAux_keys hu hpath hacc)
+  · rename_i u v w
+    simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu
+    exact normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) hpath
+      (normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) hpath hacc)
+  · rename_i u v w
+    simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu
+    exact normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hv, _, hw, rfl⟩) hpath
+      (normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) hpath hacc)
+  · rename_i u v
+    simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨hv, rfl⟩, rfl⟩ := hu
+    have hvls : v ∈ ls := List.idxOf_lt_length_iff.1 hv
+    split <;> rename_i h
+    · refine normalizeAux_keys hu (fun x hx => ?_) fun q hq => ?_
+      · exact ((Extend1.orderedInsert h).mem.1 hx).elim (fun e => e.symm ▸ hvls) (hpath x)
+      · obtain e | hq' := NormLevel.addNode_keys hq
+        · exact fun x hx => by
+            rcases (Extend1.orderedInsert h).mem.1 (e ▸ hx) with rfl | hx'
+            · exact hvls
+            · exact hpath x hx'
+        · exact (NormLevel.addConst_keys hq').elim
+            (fun e x hx => hpath x (e ▸ hx)) (hacc q)
+    · dsimp; split
+      · exact normalizeAux_keys hu hpath hacc
+      · exact normalizeAux_keys hu hpath fun q hq => hacc q (NormLevel.addVar_keys hq)
+  · exact hacc
+  · exact hacc
+  · rename_i v
+    simp [VLevel.ofLevel] at hu; obtain ⟨hv, rfl⟩ := hu
+    have hvls : v ∈ ls := List.idxOf_lt_length_iff.1 hv
+    split <;> rename_i h
+    · intro q hq
+      obtain e | hq' := NormLevel.addNode_keys hq
+      · exact fun x hx => by
+          rcases (Extend1.orderedInsert h).mem.1 (e ▸ hx) with rfl | hx'
+          · exact hvls
+          · exact hpath x hx'
+      · exact (NormLevel.addConst_keys hq').elim
+          (fun e x hx => hpath x (e ▸ hx)) (hacc q)
+    · split
+      · exact hacc
+      · exact fun q hq => hacc q (NormLevel.addVar_keys hq)
+
+theorem normalize_keys (hu : VLevel.ofLevel ls u = some u') :
+    ∀ p n, (normalize u).get? p = some n → ∀ x ∈ p, x ∈ ls := by
+  intro p n h
+  obtain ⟨n₀, h₀, -⟩ := NormLevel.subsumption_covers.1 p n h
+  have hc : (normalizeAux u [] 0 {}).contains p :=
+    Std.TreeMap.isSome_getElem?_eq_contains.symm.trans
+      (by simp [Std.TreeMap.get?_eq_getElem?] at h₀; simp [h₀])
+  exact normalizeAux_keys hu (by simp) (fun q hq => by simp at hq) p hc
+
+/-- A single sublevel of the canonical form: `Sub.const p k` is `C(p, k)` and
+`Sub.var p x k` is `V(p, x, k)`. -/
+inductive Sub where
+  | const (p : List Name) (k : Nat)
+  | var (p : List Name) (x : Name) (k : Nat)
+
+def Sub.path : Sub → List Name
+  | .const p _ => p
+  | .var p _ _ => p
+
+/-- Domination of sublevels, following Theorem 39: `s.le t` when `t`'s value bounds `s`'s
+value under every valuation. The dominator's condition set is a *subset*, so that it fires
+whenever the dominated sublevel does; a constant is dominated by `V(F, x, K)` up to `K + 1`
+since that sublevel is at least `K + 1` whenever its conditions hold; and a variable
+sublevel is only dominated by the same variable at a larger offset. -/
+protected def Sub.le : Sub → Sub → Prop
+  | .const p k, .const q l => (∀ z ∈ q, z ∈ p) ∧ k ≤ l
+  | .const p k, .var q _ l => (∀ z ∈ q, z ∈ p) ∧ k ≤ l + 1
+  | .var _ _ _, .const _ _ => False
+  | .var p x k, .var q y l => (∀ z ∈ q, z ∈ p) ∧ x = y ∧ k ≤ l
+
+protected theorem Sub.le.trans : ∀ {a b c : Sub}, a.le b → b.le c → a.le c
+  | .const _ _, .const _ _, .const _ _, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ =>
+    ⟨fun z hz => s₁ _ (s₂ _ hz), Nat.le_trans h₁ h₂⟩
+  | .const _ _, .const _ _, .var _ _ _, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ =>
+    ⟨fun z hz => s₁ _ (s₂ _ hz), by omega⟩
+  | .const _ _, .var _ _ _, .const _ _, _, h₂ => h₂.elim
+  | .const _ _, .var _ _ _, .var _ _ _, ⟨s₁, h₁⟩, ⟨s₂, _, h₂⟩ =>
+    ⟨fun z hz => s₁ _ (s₂ _ hz), by omega⟩
+  | .var _ _ _, .const _ _, _, h₁, _ => h₁.elim
+  | .var _ _ _, .var _ _ _, .const _ _, _, h₂ => h₂.elim
+  | .var _ _ _, .var _ _ _, .var _ _ _, ⟨s₁, e₁, h₁⟩, ⟨s₂, e₂, h₂⟩ =>
+    ⟨fun z hz => s₁ _ (s₂ _ hz), e₁.trans e₂, Nat.le_trans h₁ h₂⟩
+
+theorem subset_antisymm (h₁ : Sorted l₁) (h₂ : Sorted l₂)
+    (h : ∀ z ∈ l₁, z ∈ l₂) (h' : ∀ z ∈ l₂, z ∈ l₁) : l₁ = l₂ :=
+  subset_eq (subset_of_sorted h₁ h₂ h) <|
+    Nat.le_antisymm (subset_length (subset_of_sorted h₁ h₂ h))
+      (subset_length (subset_of_sorted h₂ h₁ h'))
+
+protected theorem Sub.le.antisymm : ∀ {a b : Sub}, Sorted a.path → Sorted b.path →
+    a.le b → b.le a → a = b
+  | .const p _, .const q _, ha, hb, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ => by
+    rw [subset_antisymm (l₁ := p) (l₂ := q) ha hb s₂ s₁, Nat.le_antisymm h₁ h₂]
+  | .const _ _, .var _ _ _, _, _, _, h₂ => h₂.elim
+  | .var _ _ _, .const _ _, _, _, h₁, _ => h₁.elim
+  | .var p _ _, .var q _ _, ha, hb, ⟨s₁, e₁, h₁⟩, ⟨s₂, e₂, h₂⟩ => by
+    rw [subset_antisymm (l₁ := p) (l₂ := q) ha hb s₂ s₁, e₁, Nat.le_antisymm h₁ h₂]
+
+/-- The sublevels recorded in a `NormLevel`: `C(p, n.const)` for nonzero constants and
+`V(p, x, k)` for each recorded variable. -/
+def NormLevel.HasSub (s : NormLevel) : Sub → Prop
+  | .const p k => ∃ n, s.get? p = some n ∧ n.const = k ∧ k ≠ 0
+  | .var p x k => ∃ n, s.get? p = some n ∧ ⟨x, k⟩ ∈ n.var
+
+variable (ls : List Name) (ρ : List Nat) in
+def Sub.eval : Sub → Nat
+  | .const p k => evalPath ls ρ p k
+  | .var p x k => evalPath ls ρ p (evalParam ls ρ x + k)
+
+theorem NormLevel.HasSub.le_eval {s : NormLevel} : ∀ {t}, s.HasSub t →
+    t.eval ls ρ ≤ s.eval ls ρ
+  | .const _ _, ⟨_, hn, hk, _⟩ =>
+    Nat.le_trans (evalPath_mono (hk ▸ Node.const_le_eval))
+      (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn)
+  | .var _ _ _, ⟨_, hn, hx⟩ =>
+    Nat.le_trans (evalPath_mono (Node.var_le_eval hx))
+      (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn)
+
+theorem NormLevel.lt_eval {s : NormLevel} :
+    m < eval ls ρ s ↔ ∃ p n, s.get? p = some n ∧ m < evalPath ls ρ p (Node.eval ls ρ n) := by
+  refine ⟨fun h => ?_, fun ⟨p, n, hn, hlt⟩ =>
+    Nat.lt_of_lt_of_le hlt (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn)⟩
+  refine Classical.byContradiction fun hc => ?_
+  exact absurd (eval_le.2 fun p n hn => Nat.not_lt.1 fun hlt => hc ⟨p, n, hn, hlt⟩)
+    (Nat.not_le.2 h)
+
+theorem Node.lt_eval {n : Node} :
+    m < Node.eval ls ρ n ↔ m < n.const ∨ ∃ v ∈ n.var, m < VarNode.eval ls ρ v := by
+  refine ⟨fun h => ?_, fun h => ?_⟩
+  · refine Classical.byContradiction fun hc => ?_
+    rw [not_or] at hc; obtain ⟨h₁, h₂⟩ := hc
+    refine absurd (Node.eval_le.2 ⟨Nat.not_lt.1 h₁, fun v hv => Nat.not_lt.1 fun hlt => ?_⟩)
+      (Nat.not_le.2 h)
+    exact h₂ ⟨v, hv, hlt⟩
+  · obtain h | ⟨v, hv, h⟩ := h
+    · exact Nat.lt_of_lt_of_le h Node.const_le_eval
+    · exact Nat.lt_of_lt_of_le h (Node.var_le_eval hv)
+
+theorem lt_evalPath (h : m < evalPath ls ρ p n) : allNZ ls ρ p ∧ m < n := by
+  rw [evalPath] at h; split at h
+  · exact ⟨‹_›, h⟩
+  · exact absurd h (Nat.not_lt_zero m)
+
+theorem evalParam_map {f : Name → Nat} (hx : x ∈ ls) : evalParam ls (ls.map f) x = f x := by
+  have hv : ls.idxOf x < ls.length := List.idxOf_lt_length_iff.2 hx
+  rw [evalParam_eq hv, List.getElem?_map, List.getElem?_eq_getElem hv]
+  simp [List.getElem_idxOf]
+
+theorem evalParam_not_mem (hx : x ∉ ls) : evalParam ls ρ x = 0 := by
+  simp only [evalParam]
+  rw [if_neg fun h => hx (List.idxOf_lt_length_iff.1 h)]
+
+theorem evalParam_map_pos {f : Name → Nat} (h : 0 < evalParam ls (ls.map f) z) :
+    z ∈ ls ∧ 0 < f z := by
+  by_cases hz : z ∈ ls
+  · refine ⟨hz, ?_⟩; rwa [evalParam_map hz] at h
+  · rw [evalParam_not_mem hz] at h; exact absurd h (Nat.lt_irrefl 0)
+
+theorem evalParam_map_le {f : Name → Nat} (hb : f z ≤ c) :
+    evalParam ls (ls.map f) z ≤ c := by
+  by_cases hz : z ∈ ls
+  · rw [evalParam_map hz]; exact hb
+  · rw [evalParam_not_mem hz]; exact Nat.zero_le _
+
+theorem foldl_max_le {f : α → Nat} {m : Nat} : ∀ {l : List α} {i : Nat},
+    l.foldl (fun r a => max' r (f a)) i ≤ m ↔ i ≤ m ∧ ∀ a ∈ l, f a ≤ m
+  | [], _ => by simp
+  | a :: l, i => by simp [foldl_max_le (l := l), Nat.max_le, and_assoc]
+
+/-- A bound on all the constants and offsets appearing in the map. -/
+def Node.bound (n : Node) : Nat := n.var.foldl (fun r v => max' r v.offset) n.const
+
+def NormLevel.bound (s : NormLevel) : Nat := s.foldl (fun r _ n => max' r n.bound) 0
+
+theorem NormLevel.bound_spec {s : NormLevel} (h : s.get? p = some n) :
+    n.const ≤ s.bound ∧ ∀ v ∈ n.var, v.offset ≤ s.bound := by
+  have hmem := Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (Std.TreeMap.get?_eq_getElem? .. ▸ h)
+  have hb : n.bound ≤ s.bound := by
+    rw [bound, Std.TreeMap.foldl_eq_foldl_toList]
+    exact ((foldl_max_le (f := fun pn : List Name × Node => pn.2.bound)).1
+      (Nat.le_refl _)).2 _ hmem
+  exact (foldl_max_le (f := fun v : VarNode => v.offset)).1 hb
+
+/-- The separation theorem, a converse to Theorem 39: if the value of `l₁` is bounded by the
+value of `l₂` under every valuation, then every sublevel of `l₁` has a syntactic dominator
+among the sublevels of `l₂`. The valuation exhibiting the dominator sets every variable of
+the sublevel's condition set to `1`, the sublevel's own variable (if any) to a value `N`
+larger than every constant and offset of `l₂`, and everything else to `0`: only entries of
+`l₂` at condition sets below the sublevel's can contribute, and only a sublevel with the
+same variable can reach `N`. -/
+theorem NormLevel.separation {l₁ l₂ : NormLevel}
+    (hls : ∀ p n, l₁.get? p = some n → ∀ x ∈ p, x ∈ ls)
+    (wf₁ : ∀ p n, l₁.get? p = some n → ∀ v ∈ n.var, v.var ∈ p)
+    (h : ∀ ρ, l₁.eval ls ρ ≤ l₂.eval ls ρ) :
+    ∀ t, l₁.HasSub t → ∃ t', l₂.HasSub t' ∧ t.le t' := by
+  intro t ht
+  match t, ht with
+  | .const p k, ⟨n, hn, hk, hk0⟩ =>
+    have hnz : allNZ ls (ls.map fun z => if z ∈ p then 1 else 0) p := by
+      simp only [allNZ, List.all_eq_true, decide_eq_true_eq]
+      intro z hz
+      rw [evalParam_map (hls _ _ hn _ hz)]; simp [hz]
+    have h₁ : k ≤ l₁.eval ls (ls.map fun z => if z ∈ p then 1 else 0) :=
+      Nat.le_trans (by simp [Sub.eval, evalPath, hnz])
+        (HasSub.le_eval (t := .const p k) ⟨n, hn, hk, hk0⟩)
+    have h₂ := NormLevel.lt_eval.1 (Nat.lt_of_lt_of_le (by omega : k - 1 < k)
+      (Nat.le_trans h₁ (h _)))
+    obtain ⟨q, m, hq, hlt⟩ := h₂
+    obtain ⟨hnzq, hlt⟩ := lt_evalPath hlt
+    have hsub : ∀ z ∈ q, z ∈ p := by
+      intro z hz
+      simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnzq
+      have := (evalParam_map_pos (hnzq z hz)).2
+      split at this
+      · assumption
+      · exact absurd this (Nat.lt_irrefl 0)
+    obtain hc | ⟨v, hv, hvlt⟩ := Node.lt_eval.1 hlt
+    · exact ⟨.const q m.const, ⟨m, hq, rfl, by omega⟩, hsub, by omega⟩
+    · refine ⟨.var q v.var v.offset, ⟨m, hq, hv⟩, hsub, ?_⟩
+      have hev : evalParam ls (ls.map fun z => if z ∈ p then 1 else 0) v.var ≤ 1 :=
+        evalParam_map_le (by split <;> omega)
+      simp only [VarNode.eval] at hvlt
+      omega
+  | .var p x k, ⟨n, hn, hx⟩ =>
+    have hxp : x ∈ p := wf₁ _ _ hn _ hx
+    have hxls : x ∈ ls := hls _ _ hn _ hxp
+    have hnz : allNZ ls (ls.map fun z =>
+        if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) p := by
+      simp only [allNZ, List.all_eq_true, decide_eq_true_eq]
+      intro z hz
+      simp only [evalParam_map (hls _ _ hn _ hz)]
+      split
+      · omega
+      · omega
+    have h₁ : l₂.bound + k + 2 + k ≤ l₁.eval ls (ls.map fun z =>
+        if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) := by
+      refine Nat.le_trans ?_ (HasSub.le_eval (t := .var p x k) ⟨n, hn, hx⟩)
+      simp [Sub.eval, evalPath, hnz, evalParam_map hxls]
+    obtain ⟨q, m, hq, hlt⟩ := NormLevel.lt_eval.1
+      (Nat.lt_of_lt_of_le (by omega : l₂.bound + k + 2 + k - 1 < l₂.bound + k + 2 + k)
+        (Nat.le_trans h₁ (h _)))
+    obtain ⟨hnzq, hlt⟩ := lt_evalPath hlt
+    have hsub : ∀ z ∈ q, z ∈ p := by
+      intro z hz
+      simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnzq
+      have := (evalParam_map_pos (hnzq z hz)).2
+      split at this
+      · rename_i hz'; subst hz'; exact hxp
+      · split at this
+        · assumption
+        · exact absurd this (Nat.lt_irrefl 0)
+    obtain hc | ⟨v, hv, hvlt⟩ := Node.lt_eval.1 hlt
+    · exact absurd hc (by have := (bound_spec hq).1; omega)
+    · by_cases hvx : v.var = x
+      · refine ⟨.var q x v.offset, ⟨m, hq, by rw [← hvx]; exact hv⟩, hsub, rfl, ?_⟩
+        simp [VarNode.eval, hvx, evalParam_map hxls] at hvlt
+        omega
+      · have hoff := (bound_spec hq).2 _ hv
+        have hev : evalParam ls (ls.map fun z =>
+            if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) v.var ≤ 1 :=
+          evalParam_map_le (by rw [if_neg hvx]; split <;> omega)
+        simp only [VarNode.eval] at hvlt
+        exact absurd hvlt (by omega)
+
+private theorem name_lt_ne {a b : Name} (h : compare a b = .lt) : a ≠ b := by
+  rintro rfl; rw [Std.ReflOrd.compare_self] at h; cases h
+
+/-- Exactness of `subsumeVars` on sorted lists: a surviving variable has no dominator
+in the subtracted list. -/
+theorem subsumeVars_complete {x y : VarNode} : ∀ {vs₁ vs₂ : List VarNode},
+    VarsSorted vs₁ → VarsSorted vs₂ → x ∈ subsumeVars vs₁ vs₂ → y ∈ vs₂ →
+    y.var = x.var → x.offset ≤ y.offset → False
+  | [], _, _, _, hx, _ => by simp [subsumeVars] at hx
+  | _ :: _, [], _, _, _, hy => nomatch hy
+  | a :: vs₁, b :: vs₂, h₁, h₂, hx, hy => by
+    intro e hle
+    simp only [subsumeVars] at hx
+    split at hx <;> rename_i hab
+    · rcases List.mem_cons.1 hx with rfl | hx'
+      · rcases List.mem_cons.1 hy with rfl | hy'
+        · exact name_lt_ne hab e.symm
+        · exact name_lt_ne (Std.TransCmp.lt_trans hab (h₂.head _ hy')) e.symm
+      · exact subsumeVars_complete h₁.of_cons h₂ hx' hy e hle
+    · have eab : a.var = b.var := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hab)
+      split at hx <;> rename_i hoff
+      · rcases List.mem_cons.1 hy with rfl | hy'
+        · exact name_lt_ne (h₁.head _ (subsumeVars_subset hx)) (eab.trans e)
+        · exact subsumeVars_complete h₁.of_cons h₂.of_cons hx hy' e hle
+      · rcases List.mem_cons.1 hx with rfl | hx'
+        · rcases List.mem_cons.1 hy with rfl | hy'
+          · exact hoff hle
+          · exact name_lt_ne (h₂.head _ hy') (e.trans eab).symm
+        · rcases List.mem_cons.1 hy with rfl | hy'
+          · exact name_lt_ne (h₁.head _ (subsumeVars_subset hx')) (eab.trans e)
+          · exact subsumeVars_complete h₁.of_cons h₂.of_cons hx' hy' e hle
+    · rcases List.mem_cons.1 hy with rfl | hy'
+      · have hbx : compare y.var x.var = .lt := by
+          have hba := Std.OrientedCmp.lt_of_gt hab
+          rcases List.mem_cons.1 (subsumeVars_subset hx) with rfl | hxv
+          · exact hba
+          · exact Std.TransCmp.lt_trans hba (h₁.head _ hxv)
+        exact name_lt_ne hbx e
+      · exact subsumeVars_complete h₁ h₂.of_cons hx hy' e hle
+
+theorem le_foldl_max_self {vs : List VarNode} : ∀ {n : Nat}, n ≤ vs.foldl (·.max ·.offset) n := by
+  induction vs with | nil => exact Nat.le_refl _ | cons a vs ih
+  exact fun {n} => Nat.le_trans (Nat.le_max_left _ _) ih
+
+theorem foldl_max_ge {vs : List VarNode} (hy : y ∈ vs) :
+    ∀ {n : Nat}, y.offset ≤ vs.foldl (·.max ·.offset) n := by
+  induction vs with | nil => cases hy | cons a vs ih
+  rcases List.mem_cons.1 hy with rfl | hy'
+  · exact fun {n} => Nat.le_trans (Nat.le_max_right _ _) le_foldl_max_self
+  · exact fun {n} => ih hy'
+
+/-- Exactness of the constant part of `subsumeBy`: a dominated constant is dropped. -/
+theorem Node.subsumeBy_const_complete {same : Bool} {n₁ n₂ : Node}
+    (h : (same = false ∧ n₁.const ≤ n₂.const) ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1) :
+    (n₁.subsumeBy same n₂).const = 0 := by
+  rw [Node.subsumeBy_const_eq]
+  split <;> [rename_i hc; rfl]
+  simp only [Bool.or_eq_true, Bool.and_eq_true, decide_eq_true_eq, List.isEmpty_iff] at hc
+  obtain hc | ⟨hc1, hc2⟩ := hc
+  · exact hc
+  obtain ⟨rfl, hle⟩ | ⟨y, hy, hle⟩ := h
+  · rcases hc1 with hc1 | hc1
+    · cases hc1
+    · omega
+  · rcases hc2 with hc2 | hc2
+    · rw [hc2] at hy; cases hy
+    · have := foldl_max_ge hy (n := 0); omega
+
+theorem Node.subsumeBy_var_sublist {same : Bool} {n₁ n₂ : Node} :
+    List.Sublist (n₁.subsumeBy same n₂).var n₁.var := by
+  rw [Node.subsumeBy_var_eq]; split
+  · exact List.Sublist.refl _
+  · exact subsumeVars_sublist ..
+
+/-- Exactness of the variable part of `subsumeBy` at a different key: a dominated variable
+is dropped. -/
+theorem Node.subsumeBy_var_complete {n₁ n₂ : Node} (h₁ : VarsSorted n₁.var)
+    (h₂ : VarsSorted n₂.var) (hx : x ∈ (n₁.subsumeBy false n₂).var) (hy : y ∈ n₂.var)
+    (e : y.var = x.var) (hle : x.offset ≤ y.offset) : False := by
+  rw [Node.subsumeBy_var_eq] at hx
+  split at hx <;> rename_i hc
+  · simp only [Bool.false_or, List.isEmpty_iff] at hc
+    rw [hc] at hy; cases hy
+  · exact subsumeVars_complete h₁ h₂ hx hy e hle
+
+/-- Completeness of the discharging fold in `NormLevel.le`: if every sublevel of `n₁` has a
+dominator among the entries of `l` at a subkey of `p₁`, the fold discharges everything and
+returns `none`. -/
+theorem NormLevel.le_fold_complete {p₁ : List Name} :
+    ∀ (l : List (List Name × Node)) (n₁ : Node), VarsSorted n₁.var →
+    (∀ pn ∈ l, VarsSorted pn.2.var) → n₁.isEmpty = false →
+    (n₁.const ≠ 0 → ∃ pn ∈ l, subset compare pn.1 p₁ ∧
+      (n₁.const ≤ pn.2.const ∨ ∃ y ∈ pn.2.var, n₁.const ≤ y.offset + 1)) →
+    (∀ x ∈ n₁.var, ∃ pn ∈ l, subset compare pn.1 p₁ ∧
+      ∃ y ∈ pn.2.var, y.var = x.var ∧ x.offset ≤ y.offset) →
+    List.foldlM (m := Option) (fun n pn =>
+      if subset compare pn.1 p₁ then
+        if (n.subsumeBy false pn.2).isEmpty then none else some (n.subsumeBy false pn.2)
+      else some n) n₁ l = none
+  | [], n₁, _, _, hne, hconst, hvar => by
+    rw [Node.isEmpty, Bool.and_eq_false_iff] at hne
+    obtain h0 | hv := hne
+    · obtain ⟨_, h, -⟩ := hconst (by simpa using h0)
+      cases h
+    · obtain ⟨x, hx⟩ := List.exists_mem_of_ne_nil _ (by simpa using hv)
+      obtain ⟨_, h, -⟩ := hvar x hx
+      cases h
+  | pn :: l, n₁, hvs₁, hvsl, hne, hconst, hvar => by
+    simp only [List.foldlM_cons]
+    split <;> rename_i hs
+    · by_cases he : (n₁.subsumeBy false pn.2).isEmpty <;> simp [he]
+      refine le_fold_complete l _ (hvs₁.sublist Node.subsumeBy_var_sublist)
+        (fun pn h => hvsl _ (.tail _ h)) (by simpa using he) ?_ ?_
+      · intro h0
+        have hc : (n₁.subsumeBy false pn.2).const = n₁.const :=
+          (Node.subsumeBy_const_cases ..).resolve_right h0
+        obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst (hc ▸ h0)
+        rcases List.mem_cons.1 hpn' with rfl | hpn'
+        · exact absurd (Node.subsumeBy_const_complete
+            (hdom'.imp (fun h => ⟨rfl, h⟩) id)) h0
+        · exact ⟨pn', hpn', hsub', hc ▸ hdom'⟩
+      · intro x hx
+        obtain ⟨pn', hpn', hsub', y, hy, e, hle⟩ := hvar x (Node.subsumeBy_var_subset hx)
+        rcases List.mem_cons.1 hpn' with rfl | hpn'
+        · exact (Node.subsumeBy_var_complete hvs₁ (hvsl _ (.head _)) hx hy e hle).elim
+        · exact ⟨pn', hpn', hsub', y, hy, e, hle⟩
+    · refine le_fold_complete l n₁ hvs₁ (fun pn h => hvsl _ (.tail _ h)) hne
+        (fun h0 => ?_) (fun x hx => ?_)
+      · obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst h0
+        rcases List.mem_cons.1 hpn' with rfl | hpn'
+        · exact absurd hsub' hs
+        · exact ⟨pn', hpn', hsub', hdom'⟩
+      · obtain ⟨pn', hpn', hsub', hy⟩ := hvar x hx
+        rcases List.mem_cons.1 hpn' with rfl | hpn'
+        · exact absurd hsub' hs
+        · exact ⟨pn', hpn', hsub', hy⟩
+
+/-- Completeness of `NormLevel.le`: per-sublevel domination implies acceptance. -/
+theorem NormLevel.le_complete {l₁ l₂ : NormLevel}
+    (hvs₁ : l₁.SortedVars) (hvs₂ : l₂.SortedVars)
+    (hne : ∀ p n, l₁.get? p = some n → n.isEmpty = false)
+    (hsort₁ : ∀ p n, l₁.get? p = some n → Sorted p)
+    (hsort₂ : ∀ p n, l₂.get? p = some n → Sorted p)
+    (hdom : ∀ t, l₁.HasSub t → ∃ t', l₂.HasSub t' ∧ t.le t') :
+    l₁.le l₂ := by
+  rw [NormLevel.le, Std.TreeMap.all_eq_all_toList, List.all_eq_true]
+  rintro ⟨p₁, n₁⟩ hmem
+  have h₁ := Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hmem
+  simp only [Std.TreeMap.foldlM_eq_foldlM_toList, Option.isNone_iff_eq_none]
+  have hmem₂ : ∀ q m, l₂.get? q = some m → (q, m) ∈ l₂.toList := fun q m h =>
+    Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (Std.TreeMap.get?_eq_getElem? .. ▸ h)
+  refine le_fold_complete l₂.toList n₁ (hvs₁ _ _ h₁)
+    (fun pn h => hvs₂ _ _ <| Std.TreeMap.get?_eq_getElem? .. ▸
+      Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h) (hne _ _ h₁) (fun h0 => ?_) (fun x hx => ?_)
+  · obtain ⟨t', ht', hle⟩ := hdom (.const p₁ n₁.const) ⟨n₁, h₁, rfl, h0⟩
+    match t', ht', hle with
+    | .const q _, ⟨m, hq, hc, _⟩, ⟨hsub, hle⟩ =>
+      exact ⟨(q, m), hmem₂ _ _ hq,
+        subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, .inl (hc ▸ hle)⟩
+    | .var q yv yk, ⟨m, hq, hyk⟩, ⟨hsub, hle⟩ =>
+      exact ⟨(q, m), hmem₂ _ _ hq,
+        subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, .inr ⟨⟨yv, yk⟩, hyk, hle⟩⟩
+  · obtain ⟨t', ht', hle⟩ := hdom (.var p₁ x.var x.offset) ⟨n₁, h₁, hx⟩
+    match t', ht', hle with
+    | .const _ _, _, hle => exact hle.elim
+    | .var q yv yk, ⟨m, hq, hyk⟩, ⟨hsub, hev, hle⟩ =>
+      exact ⟨(q, m), hmem₂ _ _ hq,
+        subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, ⟨yv, yk⟩, hyk, hev.symm, hle⟩
+
+/-- Two key-sorted entry lists with the same entries are equal. -/
+theorem sorted_pairs_eq : ∀ {l₁ l₂ : List (List Name × Node)},
+    l₁.Pairwise (compare ·.1 ·.1 = .lt) → l₂.Pairwise (compare ·.1 ·.1 = .lt) →
+    (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂
+  | [], [], _, _, _ => rfl
+  | [], _ :: _, _, _, h => nomatch (h _).2 (.head _)
+  | _ :: _, [], _, _, h => nomatch (h _).1 (.head _)
+  | a :: l₁, b :: l₂, h₁, h₂, h => by
+    have head₁ := (List.pairwise_cons.1 h₁).1
+    have head₂ := (List.pairwise_cons.1 h₂).1
+    cases show a = b by
+      rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip]
+      rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip]
+      cases Std.OrientedCmp.not_lt_of_lt (head₁ _ hb) (head₂ _ ha)
+    refine congrArg (a :: ·) (sorted_pairs_eq (List.pairwise_cons.1 h₁).2
+      (List.pairwise_cons.1 h₂).2 fun x => ⟨fun hx => ?_, fun hx => ?_⟩)
+    · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx'
+      · have := head₁ _ hx; rw [Std.ReflOrd.compare_self] at this; cases this
+      · exact hx'
+    · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx'
+      · have := head₂ _ hx; rw [Std.ReflOrd.compare_self] at this; cases this
+      · exact hx'
+
+/-! ### The flat fast path
+
+For a level with no essential `imax`, `normalize` produces a map with the constant at the
+root and one single-variable node per parameter (`NormLevel.Flat`), and `toTree` reads that
+off directly, so building the `NormLevel` can be skipped entirely. -/
+
+/-- The map `normalize` produces for a flat level, pointwise: `C(∅, c)` at the root, and
+`V({x}, x, k)` at each singleton key whose parameter is recorded in `vs`. -/
+def flatGet (c : Nat) (vs : List VarNode) : List Name → Option Node
+  | [] => if c = 0 then none else some ⟨c, []⟩
+  | [x] => (vs.find? (·.var == x)).map fun v => ⟨0, [v]⟩
+  | _ => none
+
+def NormLevel.Flat (s : NormLevel) (c : Nat) (vs : List VarNode) : Prop :=
+  ∀ p, s.get? p = flatGet c vs p
+
+theorem find?_var_eq_some {vs : List VarNode} {x : Name} {v : VarNode} (hvs : VarsSorted vs) :
+    vs.find? (·.var == x) = some v ↔ v ∈ vs ∧ v.var = x := by
+  refine ⟨fun h => ⟨List.mem_of_find?_eq_some h, by simpa using List.find?_some h⟩, ?_⟩
+  rintro ⟨hv, rfl⟩
+  match h : vs.find? (·.var == v.var) with
+  | none => simp [List.find?_eq_none] at h; exact absurd rfl (h _ hv)
+  | some w =>
+    have hw := List.mem_of_find?_eq_some h
+    have hwe : w.var = v.var := by simpa using List.find?_some h
+    rw [h, hvs.eq_of_var_eq hw hv hwe]
+
+theorem find?_var_eq_none {vs : List VarNode} {x : Name} :
+    vs.find? (·.var == x) = none ↔ ∀ v ∈ vs, v.var ≠ x := by
+  simp [List.find?_eq_none]
+
+/-- `addVar` raises the offset of the entry for `x`, leaving the rest alone. -/
+theorem VarNode.find?_addVar {vs : List VarNode} {x y : Name} {k : Nat} (hvs : VarsSorted vs) :
+    (VarNode.addVar x k vs).find? (·.var == y) =
+      if x = y then some ⟨x, ((vs.find? (·.var == x)).map (·.offset.max k)).getD k⟩
+      else vs.find? (·.var == y) := by
+  induction vs with | nil => split <;> simp [VarNode.addVar, *] | cons w l ih
+  simp only [VarNode.addVar]
+  split <;> rename_i hc
+  · have hnone : (w :: l).find? (·.var == x) = none := by
+      refine find?_var_eq_none.2 fun v hv => ?_
+      obtain rfl | hv := List.mem_cons.1 hv
+      · exact fun e => name_lt_ne hc e.symm
+      · exact fun e => name_lt_ne (Std.TransCmp.lt_trans hc (hvs.head _ hv)) e.symm
+    split <;> rename_i h
+    · subst h; rw [List.find?_cons_of_pos (by simp), hnone]; rfl
+    · rw [List.find?_cons_of_neg (by simp [h])]
+  · have e := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc)
+    split <;> rename_i h
+    · subst h; rw [List.find?_cons_of_pos (by simp), List.find?_cons_of_pos (by simp [← e])]; rfl
+    · rw [List.find?_cons_of_neg (by simp [h]), List.find?_cons_of_neg (by simp [← e, h])]
+  · have hne := name_lt_ne (Std.OrientedCmp.lt_of_gt hc)
+    by_cases hy : w.var = y
+    · rw [if_neg (hy ▸ hne.symm), List.find?_cons_of_pos (by simp [hy]),
+        List.find?_cons_of_pos (by simp [hy])]
+    · rw [List.find?_cons_of_neg (by simp [hy]), ih hvs.of_cons,
+        List.find?_cons_of_neg (by simp [hne]), List.find?_cons_of_neg (by simp [hy])]
+
+theorem NormLevel.addConst_flat {s : NormLevel} {c k : Nat} {vs : List VarNode}
+    (h : s.Flat c vs) : (addConst k [] s).Flat (Nat.max c k) vs := by
+  by_cases hk : k = 0
+  · subst hk
+    rw [show Nat.max c 0 = c from Nat.max_zero c, NormLevel.addConst, if_pos (by simp)]
+    exact h
+  · rw [NormLevel.addConst, if_neg (by simp [hk])]
+    intro p
+    rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter]
+    have hmax : ¬Nat.max c k = 0 := by simp only [Nat.max_eq_zero_iff]; simp [hk]
+    split <;> rename_i he
+    · cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he)
+      rw [← Std.TreeMap.get?_eq_getElem?, h []]
+      simp only [flatGet]
+      by_cases hc0 : c = 0
+      · subst hc0
+        rw [if_pos rfl, if_neg hmax, show Nat.max 0 k = k from Nat.zero_max k]
+      · rw [if_neg hc0, if_neg hmax, show Nat.max c k = Nat.max k c from Nat.max_comm c k]
+    · rw [← Std.TreeMap.get?_eq_getElem?, h p]
+      match p with
+      | [] => cases he Std.ReflOrd.compare_self
+      | [_] | _ :: _ :: _ => rfl
+
+theorem NormLevel.addNode_flat {s : NormLevel} {c k : Nat} {vs : List VarNode} {x : Name}
+    (hvs : VarsSorted vs) (h : s.Flat c vs) :
+    (addNode x k [x] s).Flat c (VarNode.addVar x k vs) := by
+  intro p
+  rw [NormLevel.addNode, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter]
+  split <;> rename_i he
+  · have hp : [x] = p := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he)
+    subst hp
+    rw [← Std.TreeMap.get?_eq_getElem?, h [x]]
+    simp only [flatGet]
+    rw [VarNode.find?_addVar hvs, if_pos rfl]
+    match hfd : vs.find? (·.var == x) with
+    | none => rw [hfd]; rfl
+    | some v =>
+      have hv : v.var = x := by simpa using List.find?_some hfd
+      rw [hfd]
+      show some ({ const := 0, var := VarNode.addVar x k [v] } : Node) = _
+      rw [show VarNode.addVar x k [v] = [⟨x, v.offset.max k⟩] from by
+        simp only [VarNode.addVar, hv, Std.ReflCmp.compare_self]]; rfl
+  · rw [← Std.TreeMap.get?_eq_getElem?, h p]
+    match p with
+    | [] => rfl
+    | [y] =>
+      have hxy : x ≠ y := by rintro rfl; exact he Std.ReflOrd.compare_self
+      simp only [flatGet]
+      rw [VarNode.find?_addVar hvs, if_neg hxy]
+    | _ :: _ :: _ => rfl
+
+/-- The entries of a flat map: the root carries the constant (and is absent when it is zero),
+and every other key is a singleton carrying one variable of `vs`. -/
+private theorem flatGet_eq_some {c : Nat} {vs : List VarNode} {p : List Name} {n : Node}
+    (h : flatGet c vs p = some n) :
+    (p = [] ∧ n = ⟨c, []⟩ ∧ c ≠ 0) ∨ ∃ v ∈ vs, p = [v.var] ∧ n = ⟨0, [v]⟩ := by
+  match p with
+  | [] =>
+    simp only [flatGet] at h
+    split at h
+    · cases h
+    · exact .inl ⟨rfl, by cases h; rfl, by assumption⟩
+  | [x] =>
+    simp only [flatGet, Option.map_eq_some_iff] at h
+    obtain ⟨v, hv, rfl⟩ := h
+    have hvx : v.var = x := by simpa using List.find?_some hv
+    exact .inr ⟨v, List.mem_of_find?_eq_some hv, by rw [hvx], rfl⟩
+  | _ :: _ :: _ => simp [flatGet] at h
+
+/-- `subsumeBy` is the identity when the constant has nothing to lose (it is zero, or the two
+sit at the same condition set and the dominator has no variables) and the variables have
+nothing to lose (same condition set, or no variables to be dominated by). -/
+private theorem Node.subsumeBy_id {same : Bool} {n₁ n₂ : Node}
+    (h₁ : n₁.const = 0 ∨ (same ∧ n₂.var = []))
+    (h₂ : same ∨ n₂.var = []) : n₁.subsumeBy same n₂ = n₁ := by
+  simp only [Node.subsumeBy]
+  rcases h₁ with hz | ⟨hs, hv⟩
+  · rcases h₂ with h2 | h2 <;> simp [hz, h2]
+  · simp [hs, hv]
+
+private theorem subsume_flat_id {c : Nat} {vs : List VarNode} {p₁ p₂ : List Name} {n₁ n₂ : Node}
+    (h₁ : flatGet c vs p₁ = some n₁) (h₂ : flatGet c vs p₂ = some n₂) :
+    Node.subsume p₁ n₁ p₂ n₂ = n₁ := by
+  rw [Node.subsume]
+  split <;> [rename_i hsub; rfl]
+  obtain ⟨rfl, rfl, -⟩ | ⟨v, -, rfl, rfl⟩ := flatGet_eq_some h₂
+  · obtain ⟨rfl, rfl, -⟩ | ⟨w, -, rfl, rfl⟩ := flatGet_eq_some h₁
+    · exact Node.subsumeBy_id (.inr ⟨rfl, rfl⟩) (.inl rfl)
+    · exact Node.subsumeBy_id (.inl rfl) (.inr rfl)
+  · obtain ⟨rfl, rfl, -⟩ | ⟨w, -, rfl, rfl⟩ := flatGet_eq_some h₁
+    · exact absurd hsub (by simp [subset])
+    · exact Node.subsumeBy_id (.inl rfl) (.inl rfl)
+
+/-- Nothing in a flat map subsumes anything: a condition set is empty or a singleton, and the
+node carrying the constant has no variables. -/
+theorem NormLevel.subsumption_flat {s : NormLevel} {c : Nat} {vs : List VarNode}
+    (h : s.Flat c vs) : s.subsumption.Flat c vs := by
+  have hmin : ∀ (acc : NormLevel), acc.Flat c vs → ∀ p₁ n₁, flatGet c vs p₁ = some n₁ →
+      acc.minimize p₁ n₁ = n₁ := by
+    intro acc hacc p₁ n₁ h₁
+    rw [NormLevel.minimize, Std.TreeMap.foldl_eq_foldl_toList]
+    have hmem : ∀ pn ∈ acc.toList, flatGet c vs pn.1 = some pn.2 := fun pn hp =>
+      (hacc pn.1).symm.trans (Std.TreeMap.get?_eq_getElem? .. ▸
+        Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hp)
+    suffices ∀ (l : List (List Name × Node)), (∀ pn ∈ l, flatGet c vs pn.1 = some pn.2) →
+        List.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n₁ l = n₁ from this _ hmem
+    intro l; induction l with | nil => intro; rfl | cons pn l ih
+    intro hl
+    rw [List.foldl_cons, subsume_flat_id h₁ (hl pn (.head _))]
+    exact ih fun q hq => hl q (.tail _ hq)
+  rw [NormLevel.subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  have hmem : ∀ pn ∈ s.toList, flatGet c vs pn.1 = some pn.2 := fun pn hp =>
+    (h pn.1).symm.trans (Std.TreeMap.get?_eq_getElem? .. ▸
+      Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hp)
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (∀ pn ∈ l, flatGet c vs pn.1 = some pn.2) → acc.Flat c vs →
+      (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).Flat c vs from
+    this _ _ hmem h
+  intro l; induction l with | nil => exact fun _ _ hacc => hacc | cons pn l ih
+  obtain ⟨p₁, n₁⟩ := pn
+  refine fun acc hl hacc => ih _ (fun q hq => hl q (.tail _ hq)) fun p => ?_
+  have h₁ : flatGet c vs p₁ = some n₁ := hl _ (.head _)
+  have hne : n₁.isEmpty = false := by
+    obtain ⟨-, rfl, hc0⟩ | ⟨v, -, -, rfl⟩ := flatGet_eq_some h₁
+    · simp [Node.isEmpty, hc0]
+    · simp [Node.isEmpty]
+  rw [NormLevel.subsumption_step_get?, hmin acc hacc p₁ n₁ h₁, hne]
+  simp only [Bool.false_eq_true, if_false]
+  split <;> rename_i hp
+  · subst hp; exact h₁.symm
+  · exact hacc p
+
+/-- The inserts of `toNormLevel` fill in the singleton keys one at a time: once the starting
+map is right at every key not yet due to be written, the fold is right everywhere. -/
+private theorem toNormLevel_fold {c : Nat} {vs : List VarNode} (hvs : VarsSorted vs) :
+    ∀ (l : List VarNode) (s : NormLevel), (∀ w ∈ l, w ∈ vs) →
+      (∀ p, (∀ w ∈ l, p ≠ [w.var]) → s.get? p = flatGet c vs p) →
+      ∀ p, (l.foldl (fun s v => s.insert [v.var] ⟨0, [v]⟩) s).get? p = flatGet c vs p := by
+  intro l; induction l with | nil => intro s _ hs p; exact hs p (by simp) | cons w l ih
+  refine fun s hmem hs => ih _ (fun x hx => hmem x (.tail _ hx)) fun p hp => ?_
+  rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
+  split <;> rename_i he
+  · have hpe : [w.var] = p := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he)
+    subst hpe
+    simp only [flatGet]
+    rw [(find?_var_eq_some hvs).2 ⟨hmem w (.head _), rfl⟩]; rfl
+  · rw [← Std.TreeMap.get?_eq_getElem?]
+    refine hs p fun x hx => ?_
+    obtain rfl | hx := List.mem_cons.1 hx
+    · rintro rfl; exact he Std.ReflOrd.compare_self
+    · exact hp x hx
+
+/-- `toNormLevel` really does build a flat map. -/
+theorem toNormLevel_flat {c : Nat} {vs : List VarNode} (hvs : VarsSorted vs) :
+    (toNormLevel c vs).Flat c vs := by
+  refine toNormLevel_fold hvs vs _ (fun w hw => hw) fun p hp => ?_
+  have hnone : ∀ x, p = [x] → flatGet c vs [x] = none := by
+    rintro x rfl; simp only [flatGet]
+    rw [find?_var_eq_none.2 fun v hv he => hp v hv (by rw [he])]; rfl
+  split <;> rename_i hc
+  · subst hc
+    match p with
+    | [] => rfl
+    | [x] => rw [hnone x rfl]; rfl
+    | _ :: _ :: _ => rfl
+  · rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert]
+    split <;> rename_i he
+    · cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he); simp [flatGet, hc]
+    · match p with
+      | [] => cases he Std.ReflOrd.compare_self
+      | [x] => rw [hnone x rfl]; rfl
+      | _ :: _ :: _ => rfl
+
+/-! Two maps with the same entries need not be the same tree, so the fallback -- which seeds
+`normalizeAux` with `toNormLevel` rather than with the map the general path would have built
+-- needs `normalizeAux` and `subsumption` to respect pointwise equality. -/
+
+theorem toList_eq_of_get?_eq {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) :
+    A.toList = B.toList := by
+  refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList Std.TreeMap.ordered_keys_toList ?_
+  rintro ⟨p, n⟩
+  rw [Std.TreeMap.mem_toList_iff_getElem?_eq_some, Std.TreeMap.mem_toList_iff_getElem?_eq_some,
+    ← Std.TreeMap.get?_eq_getElem?, ← Std.TreeMap.get?_eq_getElem?, h]
+
+theorem NormLevel.addConst_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (k path p) :
+    (addConst k path A).get? p = (addConst k path B).get? p := by
+  simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢
+  rw [NormLevel.addConst, NormLevel.addConst]
+  split <;> [exact h p; skip]
+  rw [Std.TreeMap.getElem?_alter, Std.TreeMap.getElem?_alter]
+  split <;> rw [h]
+
+theorem NormLevel.addNode_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (x k path p) :
+    (addNode x k path A).get? p = (addNode x k path B).get? p := by
+  simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢
+  rw [NormLevel.addNode, NormLevel.addNode, Std.TreeMap.getElem?_alter, Std.TreeMap.getElem?_alter]
+  split <;> rw [h]
+
+theorem NormLevel.addVar_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (x k path p) :
+    (addVar x k path A).get? p = (addVar x k path B).get? p := by
+  simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢
+  rw [NormLevel.addVar, NormLevel.addVar, Std.TreeMap.getElem?_modify, Std.TreeMap.getElem?_modify]
+  split <;> rw [h]
+
+theorem normalizeAux_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (u path k) :
+    ∀ p, (normalizeAux u path k A).get? p = (normalizeAux u path k B).get? p := by
+  induction u, path, k, A using normalizeAux.induct generalizing B with
+  | case1 path k acc => simp only [normalizeAux]; exact NormLevel.addConst_congr h k path
+  | case2 path k acc a => simp only [normalizeAux]; exact NormLevel.addConst_congr h k path
+  | case3 path k acc u ih => simp only [normalizeAux]; exact ih h
+  | case4 path k acc u v ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h)
+  | case5 path k acc u v ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h)
+  | case6 path k acc u v w ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h)
+  | case7 path k acc u v w ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h)
+  | case8 path k acc u v path' he ih =>
+    simp only [normalizeAux, he]
+    exact ih (NormLevel.addNode_congr (NormLevel.addConst_congr h k path) v k path')
+  | case9 path k acc u v he acc1 =>
+    rename_i ih
+    simp only [normalizeAux, he]
+    refine ih (B := if k = 0 then B else NormLevel.addVar v k path B) fun p => ?_
+    show (if k = 0 then acc else NormLevel.addVar v k path acc).get? p =
+      (if k = 0 then B else NormLevel.addVar v k path B).get? p
+    by_cases hk : k = 0
+    · simp only [if_pos hk]; exact h p
+    · simp only [if_neg hk]; exact NormLevel.addVar_congr h v k path p
+  | case10 path k acc a => simp only [normalizeAux]; exact h
+  | case11 path k acc a b => simp only [normalizeAux]; exact h
+  | case12 path k acc v path' he =>
+    simp only [normalizeAux, he]
+    exact NormLevel.addNode_congr (NormLevel.addConst_congr h k path) v k path'
+  | case13 path acc v he => simp only [normalizeAux, he, if_pos]; exact h
+  | case14 path k acc v he hk =>
+    simp only [normalizeAux, he, if_neg hk]
+    exact NormLevel.addVar_congr h v k path
+
+theorem NormLevel.subsumption_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) :
+    ∀ p, A.subsumption.get? p = B.subsumption.get? p := by
+  rw [NormLevel.subsumption, NormLevel.subsumption, Std.TreeMap.foldl_eq_foldl_toList,
+    Std.TreeMap.foldl_eq_foldl_toList, toList_eq_of_get?_eq h]
+  let +generalize F acc pn := _
+  suffices ∀ (l : List (List Name × Node)) (acc₁ acc₂ : NormLevel),
+      (∀ p, acc₁.get? p = acc₂.get? p) → ∀ p,
+      (List.foldl F acc₁ l).get? p = (List.foldl F acc₂ l).get? p from
+    this _ _ _ h
+  intro l; induction l with | nil => exact fun _ _ h => h | cons pn l ih
+  refine fun acc₁ acc₂ hacc => ih _ _ fun p => ?_
+  have hmin : acc₁.minimize pn.1 pn.2 = acc₂.minimize pn.1 pn.2 := by
+    rw [NormLevel.minimize, NormLevel.minimize, Std.TreeMap.foldl_eq_foldl_toList,
+      Std.TreeMap.foldl_eq_foldl_toList, toList_eq_of_get?_eq hacc]
+  rw [NormLevel.subsumption_step_get?, NormLevel.subsumption_step_get?, hmin]
+  split <;> [rfl; exact hacc p]
+
+/-- What a traversal result stands for: collected data still describing the map, or a thrown
+map agreeing with it entry for entry (only entry for entry, since the thrown one was rebuilt
+from sorted data rather than in traversal order). -/
+def RepAcc : Except NormLevel (Nat × List VarNode) → NormLevel → Prop
+  | .ok (c, vs), s => VarsSorted vs ∧ s.Flat c vs
+  | .error s', s => ∀ p, s'.get? p = s.get? p
+
+/-- The traversal tracks `normalizeAux` step for step. -/
+theorem flatAux_rep (hvs : VarsSorted vs) (h : s.Flat c vs) :
+    RepAcc (flatAux l k (c, vs)) (normalizeAux l [] k s) := by
+  induction l generalizing k c vs s with simp only [flatAux, normalizeAux]
+  | zero => exact ⟨hvs, NormLevel.addConst_flat h⟩
+  | succ l ih => exact ih hvs h
+  | max a b iha ihb =>
+    have ha := iha (k := k) hvs h
+    cases hfa : flatAux a k (c, vs) with
+    | ok acc => obtain ⟨c₁, vs₁⟩ := acc; rw [hfa] at ha; exact ihb ha.1 ha.2
+    | error s₁ => rw [hfa] at ha; exact normalizeAux_congr ha b [] k
+  | param =>
+    exact ⟨VarNode.addVar_sorted hvs, NormLevel.addNode_flat hvs (NormLevel.addConst_flat h)⟩
+  | imax => exact normalizeAux_congr (fun p => (toNormLevel_flat hvs p).trans (h p).symm) _ [] k
+  | mvar => exact ⟨hvs, h⟩
+
+private theorem compare_nil_cons {x : Name} {l : List Name} :
+    compare ([] : List Name) (x :: l) = .lt := by
+  simp [compare, List.compareLex]
+
+private theorem compare_singleton {x y : Name} : compare [x] [y] = compare x y := by
+  simp only [compare, List.compareLex]
+  cases Name.cmp x y <;> rfl
+
+/-- Adding a name that sorts after everything already there appends at the end. -/
+private theorem modifyAt_append_of_lt (f : Tree → Tree) (a : Name) : ∀ (l : List (Name × Tree)),
+    (∀ q ∈ l, compare q.1 a = .lt) → modifyAt f a l = l ++ [(a, f default)]
+  | [], _ => rfl
+  | (x, t) :: l, hl => by
+    simp only [modifyAt, Std.OrientedCmp.gt_of_lt (cmp := Name.cmp) (hl (x, t) (.head _))]
+    rw [modifyAt_append_of_lt f a l fun q hq => hl q (.tail _ hq)]; rfl
+
+/-- The edge into a singleton key's node already provides `V({x}, x, 0)`. -/
+private theorem subsumeVars_singleton_self (v : VarNode) :
+    subsumeVars [v] [⟨v.var, 0⟩] = if v.offset == 0 then [] else [v] := by
+  simp only [subsumeVars, Std.ReflCmp.compare_self]
+  by_cases h : v.offset = 0 <;> simp [h] <;> omega
+
+/-- Folding the singleton keys of a flat map appends one child per parameter, in name order. -/
+private theorem flat_toTree_fold (s : NormLevel) (a : Nat) (b : List VarNode) :
+    ∀ (vs : List VarNode) (ch : List (Name × Tree)),
+    VarsSorted vs →
+    (∀ v ∈ vs, s.lexChain 1 [v.var] = [v.var]) →
+    (∀ v ∈ vs, ∀ q ∈ ch, compare q.1 v.var = .lt) →
+    List.foldl (fun t pn =>
+        let path := s.lexChain (List.length pn.1) pn.1
+        let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var
+        Tree.modify path (fun t => { t with const := pn.2.const, var }) t)
+      ⟨a, b, ch⟩ (vs.map fun v => ([v.var], (⟨0, [v]⟩ : Node)))
+      = ⟨a, b, ch ++ vs.map fun v => (v.var, (⟨0, if v.offset == 0 then [] else [v], []⟩ : Tree))⟩
+  | [], ch, _, _, _ => by simp
+  | v :: vs, ch, hvs, hlex, hch => by
+    have hch' : ∀ w ∈ vs, ∀ q ∈ ch ++ [(v.var,
+        (⟨0, if v.offset == 0 then [] else [v], []⟩ : Tree))], compare q.1 w.var = .lt := by
+      intro w hw q hq
+      rcases List.mem_append.1 hq with hq | hq
+      · exact hch w (.tail _ hw) q hq
+      · rw [List.mem_singleton] at hq; subst hq; exact hvs.head _ hw
+    have ih := flat_toTree_fold s a b vs _ hvs.of_cons (fun w hw => hlex w (.tail _ hw)) hch'
+    simp only [List.map_cons, List.foldl_cons, List.length_cons, List.length_nil,
+      hlex v (.head _), Tree.modify, subsumeVars_singleton_self]
+    rw [modifyAt_append_of_lt _ _ ch (fun q hq => hch v (.head _) q hq)]
+    exact ih.trans (by simp)
+
+/-- The entry list of a flat map, in key order. -/
+private theorem NormLevel.Flat.toList {s : NormLevel} {c : Nat} {vs : List VarNode}
+    (hvs : VarsSorted vs) (h : s.Flat c vs) :
+    s.toList = (if c = 0 then [] else [([], (⟨c, []⟩ : Node))]) ++
+      vs.map fun v => ([v.var], (⟨0, [v]⟩ : Node)) := by
+  refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList ?_ fun ⟨p, n⟩ => ?_
+  · refine List.pairwise_append.2 ⟨?_, ?_, ?_⟩
+    · by_cases hc0 : c = 0 <;> simp [hc0]
+    · rw [List.pairwise_map]
+      exact hvs.imp fun {u w} huw => by rw [compare_singleton]; exact huw
+    · intro x hx y hy
+      by_cases hc0 : c = 0
+      · simp [hc0] at hx
+      · rw [if_neg hc0, List.mem_singleton] at hx
+        subst hx
+        obtain ⟨w, -, rfl⟩ := List.mem_map.1 hy
+        exact compare_nil_cons
+  · rw [Std.TreeMap.mem_toList_iff_getElem?_eq_some, ← Std.TreeMap.get?_eq_getElem?, h p]
+    constructor <;> intro hp
+    · obtain ⟨rfl, rfl, hc0⟩ | ⟨v, hv, rfl, rfl⟩ := flatGet_eq_some hp
+      · exact List.mem_append_left _ (by rw [if_neg hc0]; exact List.mem_singleton.2 rfl)
+      · exact List.mem_append_right _ (List.mem_map.2 ⟨v, hv, rfl⟩)
+    · obtain hp | hp := List.mem_append.1 hp
+      · split at hp <;> [cases hp; rename_i hc]
+        rw [List.mem_singleton] at hp; cases hp; simp [flatGet, hc]
+      · obtain ⟨v, hv, he⟩ := List.mem_map.1 hp
+        cases he; simp only [flatGet]
+        rw [(find?_var_eq_some hvs).2 ⟨hv, rfl⟩]; rfl
+
+/-- A singleton key's chain is forced: its one element is `addable` on the empty set, thanks
+to the entry itself, and nothing remains to be completed. -/
+private theorem NormLevel.Flat.lexChain_singleton {s : NormLevel} {c : Nat} {vs : List VarNode}
+    (hvs : VarsSorted vs) (h : s.Flat c vs) {v : VarNode} (hv : v ∈ vs) :
+    s.lexChain 1 [v.var] = [v.var] := by
+  have haddable : s.addable v.var [] := by
+    rw [NormLevel.addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true]
+    refine ⟨([v.var], ⟨0, [v]⟩), Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 ?_, ?_⟩
+    · rw [← Std.TreeMap.get?_eq_getElem?, h [v.var]]
+      simp only [flatGet]
+      rw [(find?_var_eq_some hvs).2 ⟨hv, rfl⟩]; rfl
+    · simp [subset]
+  rw [NormLevel.lexChain, List.find?_cons_of_pos]
+  · simp [NormLevel.lexChain]
+  · simp only [List.erase_cons_head, haddable, Bool.true_and]; rfl
+
+/-- Reading the tree off a flat map: every key is a singleton, so its `lexChain` is forced,
+and the fold just adds one child per parameter in name order. -/
+theorem NormLevel.Flat.toTree {s : NormLevel} {c : Nat} {vs : List VarNode}
+    (hvs : VarsSorted vs) (h : s.Flat c vs) : s.toTree = flatTree c vs := by
+  rw [NormLevel.toTree, Std.TreeMap.foldl_eq_foldl_toList, NormLevel.Flat.toList hvs h]
+  have key := flat_toTree_fold s c [] vs [] hvs
+    (fun v => NormLevel.Flat.lexChain_singleton hvs h) (by simp)
+  by_cases hc0 : c = 0
+  · subst hc0; rw [if_pos rfl]; exact key
+  · rw [if_neg hc0]; exact key
+
+/-- The sublevels of a single node keyed at `p`. -/
+def Node.HasSub (p : List Name) (n : Node) : Sub → Prop
+  | .const q k => p = q ∧ n.const = k ∧ k ≠ 0
+  | .var q x k => p = q ∧ ⟨x, k⟩ ∈ n.var
+
+theorem NormLevel.hasSub_iff {s : NormLevel} {t} :
+    s.HasSub t ↔ ∃ p n, s.get? p = some n ∧ Node.HasSub p n t := by
+  match t with
+  | .const p k =>
+    constructor
+    · rintro ⟨n, hn, hk, hk0⟩; exact ⟨p, n, hn, rfl, hk, hk0⟩
+    · rintro ⟨q, n, hn, rfl, hk, hk0⟩; exact ⟨n, hn, hk, hk0⟩
+  | .var p x k =>
+    constructor
+    · rintro ⟨n, hn, hx⟩; exact ⟨p, n, hn, rfl, hx⟩
+    · rintro ⟨q, n, hn, rfl, hx⟩; exact ⟨n, hn, hx⟩
+
+theorem Node.subsume_hasSub : ∀ {t}, Node.HasSub p₁ (Node.subsume p₁ n p₂ n₂) t →
+    Node.HasSub p₁ n t
+  | .const _ k, ⟨rfl, hck, hk0⟩ => by
+    refine ⟨rfl, ?_, hk0⟩
+    obtain h | h := Node.subsume_const_cases p₁ n p₂ n₂
+    · rw [← h]; exact hck
+    · rw [h] at hck; exact absurd hck.symm hk0
+  | .var _ _ _, ⟨rfl, hxk⟩ => ⟨rfl, Node.subsume_var_subset hxk⟩
+
+theorem NormLevel.minimize_hasSub {acc : NormLevel} {t}
+    (h : Node.HasSub p₁ (acc.minimize p₁ n₁) t) : Node.HasSub p₁ n₁ t := by
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h
+  generalize acc.toList = l at h
+  induction l generalizing n₁ with
+  | nil => exact h
+  | cons a l ih => exact Node.subsume_hasSub (ih h)
+
+/-- A `subsumption` step only removes sublevels. -/
+theorem NormLevel.subsumption_step_hasSub {acc : NormLevel} {p₁ : List Name} {n₁ : Node}
+    (h₁ : acc.get? p₁ = some n₁) {t}
+    (h : NormLevel.HasSub (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁
+      else acc.insert p₁ (acc.minimize p₁ n₁)) t) : acc.HasSub t := by
+  rw [hasSub_iff] at h ⊢
+  obtain ⟨p, n, hp, hn⟩ := h
+  rw [subsumption_step_get?] at hp
+  split at hp <;> rename_i hpe
+  · split at hp <;> [cases hp; skip]
+    cases hp; subst hpe
+    exact ⟨p₁, n₁, h₁, minimize_hasSub hn⟩
+  · exact ⟨p, n, hp, hn⟩
+
+/-- Exactness of minimization, fold form: a sublevel surviving the subtraction of every entry
+in `l` is not (strictly) dominated by any of their sublevels — domination forces equality. -/
+theorem NormLevel.minimize_exact_aux {acc : NormLevel} {p₁ : List Name} {n₁ : Node}
+    (hsort : ∀ p n, acc.get? p = some n → Sorted p) (hvsa : acc.SortedVars)
+    (h₁ : acc.get? p₁ = some n₁) (hs₁ : Sorted p₁) (hvs₁ : VarsSorted n₁.var) :
+    ∀ (l : List (List Name × Node)) (n : Node),
+      (∀ pn ∈ l, acc.get? pn.1 = some pn.2) →
+      (∀ x ∈ n.var, x ∈ n₁.var) → (n.const ≠ 0 → n.const = n₁.const) → VarsSorted n.var →
+      ∀ t, Node.HasSub p₁ (l.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n) t →
+      Node.HasSub p₁ n t ∧
+        ∀ pn ∈ l, ∀ t', Node.HasSub pn.1 pn.2 t' → t.le t' → t = t'
+  | [], _, _, _, _, _, _, ht => ⟨ht, fun _ h => nomatch h⟩
+  | (p₂, n₂) :: l, n, hl, hnvar, hnconst, hvs, t, ht => by
+    simp only [List.foldl_cons] at ht
+    have h₂ : acc.get? p₂ = some n₂ := hl _ (.head _)
+    have hvs₂ : VarsSorted n₂.var := hvsa _ _ h₂
+    have hs₂ : Sorted p₂ := hsort _ _ h₂
+    obtain ⟨ht', hrest⟩ := minimize_exact_aux hsort hvsa h₁ hs₁ hvs₁ l
+      (Node.subsume p₁ n p₂ n₂) (fun pn h => hl _ (.tail _ h))
+      (fun x hx => hnvar _ (Node.subsume_var_subset hx))
+      (fun h0 => by
+        obtain hc | hc := Node.subsume_const_cases p₁ n p₂ n₂
+        · rw [hc]; exact hnconst (hc ▸ h0)
+        · exact absurd hc h0)
+      (hvs.sublist Node.subsume_var_sublist) t ht
+    refine ⟨Node.subsume_hasSub ht', ?_⟩
+    rintro pn hpn t' ht'' hle
+    rcases List.mem_cons.1 hpn with rfl | hpn
+    · obtain ⟨q, k⟩ | ⟨q, x, k⟩ := t <;> obtain ⟨q', k'⟩ | ⟨q', y, k'⟩ := t'
+      · -- const dominated by const
+        obtain ⟨rfl, hck, hk0⟩ := ht'
+        obtain ⟨rfl, hck', hk0'⟩ := ht''
+        obtain ⟨hsub, hlek⟩ := hle
+        have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub
+        have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by
+          rw [Node.subsume, if_pos hgate]
+        by_cases hlen : p₁.length = p₂.length
+        · have hqq : p₂ = p₁ := subset_eq hgate hlen.symm
+          have hn₂ : n₂ = n₁ := by
+            rw [hqq] at h₂; cases h₂.symm.trans h₁; rfl
+          have hkc : n.const = k := by
+            obtain hc | hc := Node.subsume_const_cases p₁ n p₂ n₂
+            · rw [← hc]; exact hck
+            · rw [hc] at hck; exact absurd hck.symm hk0
+          have hne0 : n.const ≠ 0 := fun h0 => hk0 (hkc.symm.trans h0)
+          rw [hqq, show k = k' from by rw [← hck', hn₂, ← hnconst hne0, hkc]]
+        · have hbeq : (p₁.length == p₂.length) = false := by simpa using hlen
+          rw [hsu, hbeq] at hck
+          have hkc : n.const = k := by
+            obtain hc | hc := Node.subsumeBy_const_cases (same := false) n n₂
+            · rw [← hc]; exact hck
+            · rw [hc] at hck; exact absurd hck.symm hk0
+          refine absurd hck ?_
+          rw [Node.subsumeBy_const_complete (n₁ := n) (n₂ := n₂)
+            (.inl ⟨rfl, by rw [hkc, hck']; exact hlek⟩)]
+          exact fun h => hk0 h.symm
+      · -- const dominated by a variable
+        obtain ⟨rfl, hck, hk0⟩ := ht'
+        obtain ⟨rfl, hyk⟩ := ht''
+        obtain ⟨hsub, hlek⟩ := hle
+        have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub
+        have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by
+          rw [Node.subsume, if_pos hgate]
+        rw [hsu] at hck
+        have hkc : n.const = k := by
+          obtain hc | hc := Node.subsumeBy_const_cases (same := p₁.length == p₂.length) n n₂
+          · rw [← hc]; exact hck
+          · rw [hc] at hck; exact absurd hck.symm hk0
+        refine absurd hck ?_
+        rw [Node.subsumeBy_const_complete (n₁ := n) (n₂ := n₂)
+          (.inr ⟨⟨y, k'⟩, hyk, by rw [hkc]; exact hlek⟩)]
+        exact fun h => hk0 h.symm
+      · exact hle.elim
+      · -- variable dominated by a variable
+        obtain ⟨rfl, hxk⟩ := ht'
+        obtain ⟨rfl, hyk⟩ := ht''
+        obtain ⟨hsub, rfl, hlek⟩ := hle
+        have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub
+        have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by
+          rw [Node.subsume, if_pos hgate]
+        by_cases hlen : p₁.length = p₂.length
+        · have hqq : p₂ = p₁ := subset_eq hgate hlen.symm
+          have hn₂ : n₂ = n₁ := by
+            rw [hqq] at h₂; cases h₂.symm.trans h₁; rfl
+          have hk : (⟨x, k⟩ : VarNode) = ⟨x, k'⟩ :=
+            hvs₁.eq_of_var_eq (hnvar _ (Node.subsume_var_subset hxk)) (hn₂ ▸ hyk) rfl
+          rw [hqq, show k = k' from congrArg VarNode.offset hk]
+        · have hbeq : (p₁.length == p₂.length) = false := by simpa using hlen
+          rw [hsu, hbeq] at hxk
+          exact (Node.subsumeBy_var_complete hvs hvs₂ hxk hyk rfl hlek).elim
+    · exact hrest _ hpn _ ht'' hle
+
+theorem NormLevel.minimize_exact {acc : NormLevel} {p₁ : List Name} {n₁ : Node}
+    (hsort : ∀ p n, acc.get? p = some n → Sorted p) (hvsa : acc.SortedVars)
+    (h₁ : acc.get? p₁ = some n₁) :
+    ∀ t t', Node.HasSub p₁ (acc.minimize p₁ n₁) t → acc.HasSub t' → t.le t' → t = t' := by
+  intro t t' ht ht' hle
+  rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at ht
+  have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  obtain ⟨-, hexact⟩ := minimize_exact_aux hsort hvsa h₁ (hsort _ _ h₁) (hvsa _ _ h₁)
+    acc.toList n₁ hmem (fun _ => id) (fun _ => rfl) (hvsa _ _ h₁) t ht
+  obtain ⟨p₂, n₂, hp₂, hn₂⟩ := hasSub_iff.1 ht'
+  exact hexact (p₂, n₂) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2
+    (Std.TreeMap.get?_eq_getElem? .. ▸ hp₂)) _ hn₂ hle
+
+/-- A normal form is reduced when no sublevel is dominated by another: domination between
+recorded sublevels forces them to be the same sublevel. -/
+def NormLevel.Reduced (s : NormLevel) : Prop :=
+  ∀ t t', s.HasSub t → s.HasSub t' → t.le t' → t = t'
+
+/-- `subsumption` produces a reduced map: every entry is minimized against the (current)
+whole map, minimization removes exactly the dominated sublevels, and later steps only
+shrink the map, which cannot introduce new domination. -/
+theorem NormLevel.subsumption_reduced {s : NormLevel}
+    (hsort : ∀ p n, s.get? p = some n → Sorted p) (hvsa : s.SortedVars) :
+    s.subsumption.Reduced := by
+  have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 :=
+    Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h
+  have nd : (s.toList.map Prod.fst).Nodup := by simpa using Std.TreeMap.nodup_keys (t := s)
+  rw [Reduced, subsumption, Std.TreeMap.foldl_eq_foldl_toList]
+  suffices ∀ (l : List (List Name × Node)) (acc : NormLevel),
+      (l.map Prod.fst).Nodup →
+      (∀ pn ∈ l, acc.get? pn.1 = some pn.2) →
+      (∀ p n, acc.get? p = some n → Sorted p) → acc.SortedVars →
+      (∀ p n, acc.get? p = some n → p ∉ l.map Prod.fst →
+        ∀ t t', Node.HasSub p n t → acc.HasSub t' → t.le t' → t = t') →
+      ∀ t t', (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).HasSub t →
+      (List.foldl (fun acc pn =>
+        let n := acc.minimize pn.1 pn.2
+        if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).HasSub t' →
+      t.le t' → t = t' from
+    this _ _ nd hmem hsort hvsa fun p n hp hnp => absurd
+      (List.mem_map_of_mem (f := Prod.fst) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2
+        (Std.TreeMap.get?_eq_getElem? .. ▸ hp))) hnp
+  clear hmem nd hsort hvsa; intro l
+  induction l with
+  | nil =>
+    intro acc _ _ _ _ hred t t' ht ht' hle
+    obtain ⟨p, n, hp, hnt⟩ := hasSub_iff.1 ht
+    exact hred p n hp (by simp) t t' hnt ht' hle
+  | cons pn l ih =>
+    obtain ⟨p₂, n₂⟩ := pn
+    intro acc nd hl hsorta hvsacc hred
+    simp only [List.map_cons, List.nodup_cons] at nd
+    have h₂ : acc.get? p₂ = some n₂ := hl _ (.head _)
+    simp only [List.foldl_cons]
+    have hstep := subsumption_step_get? acc n₂ p₂
+    refine ih _ nd.2 (fun pn' h => ?_) (fun p n h => ?_) (fun p n h => ?_)
+      (fun p n hp hnp t t' hnt ht' hle => ?_)
+    · have hne : p₂ ≠ pn'.1 := fun e => nd.1 (e ▸ List.mem_map_of_mem (f := Prod.fst) h)
+      rw [hstep, if_neg hne]
+      exact hl _ (.tail _ h)
+    · rw [hstep] at h; split at h <;> rename_i hpe
+      · split at h <;> [cases h; skip]
+        cases h; exact hpe ▸ hsorta _ _ h₂
+      · exact hsorta _ _ h
+    · rw [hstep] at h; split at h <;> rename_i hpe
+      · split at h <;> [cases h; skip]
+        cases h
+        exact (hvsacc _ _ h₂).sublist minimize_var_sublist
+      · exact hvsacc _ _ h
+    · rw [hstep] at hp; split at hp <;> rename_i hpe
+      · split at hp <;> [cases hp; skip]
+        cases hp; subst hpe
+        exact minimize_exact hsorta hvsacc h₂ t t' hnt (subsumption_step_hasSub h₂ ht') hle
+      · refine hred p n hp ?_ t t' hnt (subsumption_step_hasSub h₂ ht') hle
+        simp only [List.map_cons, List.mem_cons, not_or]
+        exact ⟨fun e => hpe e.symm, hnp⟩
+
+theorem normalize_reduced : (normalize u).Reduced := by
+  refine NormLevel.subsumption_reduced ?_ (normalizeAux_sortedVars fun _ _ => by simp)
+  exact fun p n h => (normalizeAux_wf (by simp) (by simp [NormLevel.WF]) p n h).2.2
+
+/-! Canonicity: two reduced normal forms with the same semantics have the same sublevels,
+and hence are equal maps. -/
+
+instance : LawfulBEq Node where
+  rfl {a} := by cases a <;> simp! +instances [instBEqNode]
+  eq_of_beq {a b} h := by
+    cases a; cases b
+    simp! +instances [instBEqNode] at h
+    simp [h.1, h.2]
+
+theorem VarsSorted.eq_of_mem_iff : ∀ {l₁ l₂ : List VarNode}, VarsSorted l₁ → VarsSorted l₂ →
+    (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂
+  | [], [], _, _, _ => rfl
+  | [], _ :: _, _, _, h => nomatch (h _).2 (.head _)
+  | _ :: _, [], _, _, h => nomatch (h _).1 (.head _)
+  | a :: l₁, b :: l₂, h₁, h₂, h => by
+    cases show a = b by
+      rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip]
+      rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip]
+      exact absurd (h₂.head _ ha) (by rw [Std.OrientedCmp.gt_of_lt (h₁.head _ hb)]; simp)
+    refine congrArg (a :: ·) (VarsSorted.eq_of_mem_iff h₁.of_cons h₂.of_cons
+      fun x => ⟨fun hx => ?_, fun hx => ?_⟩)
+    · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx'
+      · exact absurd (h₁.head _ hx) (by rw [Std.ReflOrd.compare_self]; simp)
+      · exact hx'
+    · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx'
+      · exact absurd (h₂.head _ hx) (by rw [Std.ReflOrd.compare_self]; simp)
+      · exact hx'
+
+theorem NormLevel.HasSub.path_sorted {s : NormLevel}
+    (hsort : ∀ p n, s.get? p = some n → Sorted p) : ∀ {t}, s.HasSub t → Sorted t.path
+  | .const _ _, ⟨_, hn, _⟩ => hsort _ _ hn
+  | .var _ _ _, ⟨_, hn, _⟩ => hsort _ _ hn
+
+/-- In reduced maps, mutual per-sublevel domination pins the sublevels to be equal: the
+dominator of a sublevel is itself dominated by a sublevel of the first map, which by
+reducedness is the sublevel we started from, and antisymmetry finishes. -/
+theorem NormLevel.Reduced.hasSub_iff_hasSub {A B : NormLevel}
+    (rA : A.Reduced) (rB : B.Reduced)
+    (sortA : ∀ p n, A.get? p = some n → Sorted p)
+    (sortB : ∀ p n, B.get? p = some n → Sorted p)
+    (hAB : ∀ t, A.HasSub t → ∃ t', B.HasSub t' ∧ t.le t')
+    (hBA : ∀ t, B.HasSub t → ∃ t', A.HasSub t' ∧ t.le t') :
+    ∀ t, A.HasSub t ↔ B.HasSub t := by
+  suffices ∀ {A B : NormLevel}, A.Reduced →
+      (∀ p n, A.get? p = some n → Sorted p) → (∀ p n, B.get? p = some n → Sorted p) →
+      (∀ t, A.HasSub t → ∃ t', B.HasSub t' ∧ t.le t') →
+      (∀ t, B.HasSub t → ∃ t', A.HasSub t' ∧ t.le t') →
+      ∀ t, A.HasSub t → B.HasSub t from
+    fun t => ⟨this rA sortA sortB hAB hBA t, this rB sortB sortA hBA hAB t⟩
+  clear rA rB sortA sortB hAB hBA
+  intro A B rA sortA sortB hAB hBA t ht
+  obtain ⟨t', ht', hle⟩ := hAB t ht
+  obtain ⟨t'', ht'', hle'⟩ := hBA t' ht'
+  cases rA t t'' ht ht'' (hle.trans hle')
+  exact (hle.antisymm (HasSub.path_sorted sortA ht) (HasSub.path_sorted sortB ht') hle').symm ▸ ht'
+
+/-- Two reduced normal forms with the same sublevels are equal as `NormLevel`s. -/
+theorem NormLevel.eq_of_hasSub_iff {A B : NormLevel}
+    (hvsA : A.SortedVars) (hvsB : B.SortedVars)
+    (hneA : ∀ p n, A.get? p = some n → n.isEmpty = false)
+    (hneB : ∀ p n, B.get? p = some n → n.isEmpty = false)
+    (h : ∀ t, A.HasSub t ↔ B.HasSub t) : A == B := by
+  suffices ∀ {A B : NormLevel}, A.SortedVars → B.SortedVars →
+      (∀ p n, A.get? p = some n → n.isEmpty = false) →
+      (∀ t, A.HasSub t ↔ B.HasSub t) →
+      ∀ p n, A.get? p = some n → B.get? p = some n by
+    have h1 := @this A B hvsA hvsB hneA h
+    have h2 := @this B A hvsB hvsA hneB fun t => (h t).symm
+    simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList,
+      Bool.and_eq_true, List.all_eq_true]
+    constructor <;> rintro ⟨p, n⟩ hpn
+    · have := h1 p n (Std.TreeMap.get?_eq_getElem? .. ▸
+        Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hpn)
+      rw [Std.TreeMap.get?_eq_getElem?] at this
+      simp [this]
+    · have := h2 p n (Std.TreeMap.get?_eq_getElem? .. ▸
+        Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hpn)
+      rw [Std.TreeMap.get?_eq_getElem?] at this
+      simp [this]
+  clear hvsA hvsB hneA hneB h
+  intro A B hvsA hvsB hneA h p n hp
+  have hne := hneA _ _ hp
+  rw [Node.isEmpty, Bool.and_eq_false_iff] at hne
+  have hBp : ∃ m, B.get? p = some m := by
+    obtain h0 | hv := hne
+    · obtain ⟨m, hm, -⟩ := (h (.const p n.const)).1 ⟨n, hp, rfl, by simpa using h0⟩
+      exact ⟨m, hm⟩
+    · obtain ⟨x, hx⟩ := List.exists_mem_of_ne_nil _ (by simpa using hv)
+      obtain ⟨m, hm, -⟩ := (h (.var p x.var x.offset)).1 ⟨n, hp, hx⟩
+      exact ⟨m, hm⟩
+  obtain ⟨m, hm⟩ := hBp
+  have hconst : n.const = m.const := by
+    by_cases h0 : n.const = 0
+    · by_cases h0' : m.const = 0
+      · rw [h0, h0']
+      · obtain ⟨n', hn', hc, -⟩ := (h (.const p m.const)).2 ⟨m, hm, rfl, h0'⟩
+        cases hn'.symm.trans hp
+        exact absurd (h0 ▸ hc).symm h0'
+    · obtain ⟨m', hm', hc, -⟩ := (h (.const p n.const)).1 ⟨n, hp, rfl, h0⟩
+      cases hm'.symm.trans hm
+      exact hc.symm
+  have hvar : n.var = m.var := by
+    refine VarsSorted.eq_of_mem_iff (hvsA _ _ hp) (hvsB _ _ hm)
+      fun x => ⟨fun hx => ?_, fun hx => ?_⟩
+    · obtain ⟨m', hm', hx'⟩ := (h (.var p x.var x.offset)).1 ⟨n, hp, hx⟩
+      cases hm'.symm.trans hm
+      exact hx'
+    · obtain ⟨n', hn', hx'⟩ := (h (.var p x.var x.offset)).2 ⟨m, hm, hx⟩
+      cases hn'.symm.trans hp
+      exact hx'
+  obtain ⟨nc, nv⟩ := n
+  obtain ⟨mc, mv⟩ := m
+  cases hconst; cases hvar
+  exact hm
+
+/-- Semantically equal levels have `BEq`-equal normal forms. -/
+theorem normalize_complete (hu : VLevel.ofLevel ls u = some u')
+    (hv : VLevel.ofLevel ls v = some v') : normalize u == normalize v ↔ u' ≈ v' := by
+  refine .trans ⟨fun h ls => ?_, fun h => ?_⟩ VLevel.equiv_def.symm
+  · rw [← normalize_eval hu, NormLevel.eval_congr h, normalize_eval hv]
+  have h₁ : ∀ ρ, (normalize u).eval ls ρ ≤ (normalize v).eval ls ρ := fun ρ => by
+    rw [normalize_eval hu, normalize_eval hv, h ρ]; exact Nat.le_refl _
+  have h₂ : ∀ ρ, (normalize v).eval ls ρ ≤ (normalize u).eval ls ρ := fun ρ => by
+    rw [normalize_eval hu, normalize_eval hv, h ρ]; exact Nat.le_refl _
+  exact NormLevel.eq_of_hasSub_iff normalize_sortedVars normalize_sortedVars
+    normalize_nonempty normalize_nonempty
+    (NormLevel.Reduced.hasSub_iff_hasSub normalize_reduced normalize_reduced
+      normalize_sorted normalize_sorted
+      (NormLevel.separation (normalize_keys hu) normalize_vars h₁)
+      (NormLevel.separation (normalize_keys hv) normalize_vars h₂))
+
+/-! `BEq`-equal maps have equal `toList`s, and the reconstruction depends on the map only
+through `toList`, so equal normal forms reify to syntactically equal levels. (`TreeMap`
+equality itself does not follow from `==`: the internal tree shape depends on insertion
+order.) -/
+
+theorem NormLevel.toList_eq {A B : NormLevel} (h : A == B) : A.toList = B.toList := by
+  simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList,
+    Bool.and_eq_true, List.all_eq_true] at h
+  refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList Std.TreeMap.ordered_keys_toList
+    fun x => ⟨fun hx => ?_, fun hx => ?_⟩
+  · have := h.1 x hx
+    rw [beq_iff_eq, Std.TreeMap.get?_eq_getElem?] at this
+    exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 this
+  · have := h.2 x hx
+    rw [beq_iff_eq, Std.TreeMap.get?_eq_getElem?] at this
+    exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 this
+
+theorem NormLevel.addable_congr {A B : NormLevel} (h : A.toList = B.toList) :
+    A.addable a acc = B.addable a acc := by
+  rw [addable, addable, Std.TreeMap.any_eq_any_toList, Std.TreeMap.any_eq_any_toList, h]
+
+theorem NormLevel.feasible_go_congr {A B : NormLevel} (h : A.toList = B.toList) :
+    ∀ fuel acc rem, NormLevel.feasible.go A fuel acc rem = NormLevel.feasible.go B fuel acc rem
+  | 0, _, _ => rfl
+  | fuel+1, acc, rem => by
+    simp only [feasible.go]
+    rw [show (fun a => A.addable a acc) = fun a => B.addable a acc from
+      funext fun a => addable_congr h]
+    cases rem.find? fun a => B.addable a acc with
+    | none => rfl
+    | some a => exact feasible_go_congr h fuel _ _
+
+theorem NormLevel.feasible_congr {A B : NormLevel} (h : A.toList = B.toList) :
+    A.feasible acc rem = B.feasible acc rem := by
+  simp only [feasible]; exact feasible_go_congr h ..
+
+theorem NormLevel.lexChain_congr {A B : NormLevel} (h : A.toList = B.toList) :
+    ∀ fuel p, A.lexChain fuel p = B.lexChain fuel p
+  | 0, _ => rfl
+  | fuel+1, p => by
+    simp only [lexChain]
+    rw [show (fun a => A.addable a (p.erase a) && A.feasible [] (p.erase a))
+        = fun a => B.addable a (p.erase a) && B.feasible [] (p.erase a) from
+      funext fun a => by rw [addable_congr h, feasible_congr h]]
+    cases p.find? fun a => B.addable a (p.erase a) && B.feasible [] (p.erase a) with
+    | none => rfl
+    | some a => exact congrArg (a :: ·) (lexChain_congr h fuel _)
+
+/-- The reconstruction depends only on the entry list of the map. -/
+theorem NormLevel.toTree_congr {A B : NormLevel} (h : A.toList = B.toList) :
+    A.toTree = B.toTree := by
+  rw [toTree, toTree, Std.TreeMap.foldl_eq_foldl_toList, Std.TreeMap.foldl_eq_foldl_toList, h]
+  congr 1
+  funext t pn
+  rw [lexChain_congr h]
+
+/-- The fast path is transparent: it computes the same tree the general path does. -/
+theorem normalize'_eq (l : Level) : normalize' l = (normalize l).toTree.reify := by
+  rw [normalize']
+  have hrep := flatAux_rep (l := l) (k := 0) (c := 0) (vs := []) (s := {}) .nil
+    (fun p => by match p with | [] | [_] | _::_::_ => simp [flatGet])
+  match hf : flatAux l 0 (0, []) with
+  | .ok (c, vs) =>
+    rw [hf] at hrep
+    obtain ⟨hvs, hflat⟩ := hrep
+    rw [normalize, (NormLevel.subsumption_flat hflat).toTree hvs]
+  | .error s =>
+    rw [hf] at hrep; dsimp only
+    rw [normalize, NormLevel.toTree_congr (toList_eq_of_get?_eq (NormLevel.subsumption_congr hrep))]
+
+end Normalize
 
 theorem isStructEq_eq {u v : Level} (h : isStructEq u v) : u = v := by
   induction u generalizing v with
@@ -1057,21 +3833,76 @@ theorem isStructEq_iff_eq {u v : Level} : isStructEq u v ↔ u = v := by
   · rintro rfl
     induction u <;> simp_all [isStructEq]
 
-theorem isEquiv_wf (h : isEquiv' u v)
+theorem isEquiv'_wf (h : isEquiv' u v)
     (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by
   simp only [isEquiv', Bool.or_eq_true] at h
   obtain h | h := h
-  · cases isStructEq_iff_eq.1 h
-    cases hu.symm.trans hv
-    rfl
-  · refine VLevel.equiv_def.2 fun ls' => ?_
-    rw [← Normalize.normalize_eval hu, ← Normalize.normalize_eval hv]
+  · exact isEquiv_wf h hu hv
+  · refine VLevel.equiv_def.2 fun ρ => ?_
+    rw [← Normalize.normalize_eval (ρ := ρ) hu, ← Normalize.normalize_eval (ρ := ρ) hv]
     exact Normalize.NormLevel.eval_congr h
 
+/-- Soundness of reification: the level `normalize'` reconstructs evaluates like the input
+everywhere. Reification is `toTree` followed by `reify`, and both preserve the value: the
+tree's `imax` chains contribute nothing the normal form does not already have, since every
+key admits a chain (`normalize_feas`) and `lexChain` then picks an admissible one, and
+nothing is lost, since every entry is recorded at the end of its chain. -/
+theorem normalize'_eval (hu : VLevel.ofLevel ls u = some u') :
+    Level.eval (Normalize.evalParam ls ρ) μ (normalize' u) = u'.eval ρ := by
+  open Normalize in
+  rw [normalize'_eq, Tree.reify_eval, NormLevel.toTree_eval normalize_sorted normalize_feas]
+  exact normalize_eval hu
+
+theorem geq'_wf (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v')
+    (h : geq' u v) : v' ≤ u' := by
+  simp only [geq', Bool.or_eq_true] at h
+  obtain h | h := h
+  · exact geq_wf h hu hv
+  · intro ρ
+    rw [← Normalize.normalize_eval (ρ := ρ) hv, ← Normalize.normalize_eval (ρ := ρ) hu]
+    exact Normalize.NormLevel.le_eval Normalize.normalize_vars h
+
 theorem isEquivList_wf (H : Level.isEquivList us vs) :
     List.mapM (VLevel.ofLevel Us) us = some us' →
     List.mapM (VLevel.ofLevel Us) vs = some vs' → us'.Forall₂ (· ≈ ·) vs' := by
   simp [Level.isEquivList] at H; revert us' vs'
   induction us generalizing vs with cases vs <;> simp [List.all2] at H <;> simp | cons u us ih
   rename_i v vs; rintro _ _ u' hu us' hus rfl v' hv vs' hvs rfl
-  exact .cons (isEquiv_wf H.1 hu hv) (ih H.2 hus hvs)
+  exact .cons (isEquiv'_wf H.1 hu hv) (ih H.2 hus hvs)
+
+/-- Canonicity of `normalize'`: semantically equal levels reconstruct to syntactically equal
+levels. The normal forms are `BEq`-equal, hence have the same entry list, and the
+reconstruction (`lexChain` and the tree fold) depends on the map only through its entry
+list. -/
+theorem normalize'_complete (hu : VLevel.ofLevel ls u = some u')
+    (hv : VLevel.ofLevel ls v = some v') : normalize' u = normalize' v ↔ u' ≈ v' := by
+  refine ⟨fun h => ?_, fun h => ?_⟩
+  · refine VLevel.equiv_def.2 fun ρ => ?_
+    rw [← normalize'_eval (μ := fun _ => 0) hu, ← normalize'_eval hv, h]
+  · rw [Normalize.normalize'_eq, Normalize.normalize'_eq]
+    rw [← Normalize.normalize_complete hu hv] at h
+    rw [Normalize.NormLevel.toTree_congr (Normalize.NormLevel.toList_eq h)]
+
+/-- Completeness of `isEquiv'`: semantically equal levels have equal normal forms. Both
+normal forms are reduced (`subsumption_reduced`), mutually dominate each other's sublevels
+(`separation`), and reduced forms with the same sublevels are the same map. -/
+theorem isEquiv'_complete (hu : VLevel.ofLevel ls u = some u')
+    (hv : VLevel.ofLevel ls v = some v') : isEquiv' u v ↔ u' ≈ v' := by
+  simp only [isEquiv', Bool.or_eq_true, Normalize.normalize_complete hu hv]
+  exact ⟨fun h => h.elim (fun h => isEquiv_wf h hu hv) id, .inr⟩
+
+/-- Completeness of `geq'`: every valid semantic inequality is accepted. Every sublevel of
+`normalize v` is semantically bounded by `normalize u`, hence syntactically dominated by one
+of its sublevels (`separation`), which is exactly what the discharging fold in
+`NormLevel.le` checks for. -/
+theorem geq'_complete (hu : VLevel.ofLevel ls u = some u')
+    (hv : VLevel.ofLevel ls v = some v') : geq' u v ↔ v' ≤ u' := by
+  open Normalize in
+  refine ⟨geq'_wf hu hv, fun h => ?_⟩
+  simp only [geq', Bool.or_eq_true]
+  refine .inr ?_
+  refine NormLevel.le_complete normalize_sortedVars normalize_sortedVars normalize_nonempty
+    normalize_sorted normalize_sorted ?_
+  refine NormLevel.separation (normalize_keys hv) normalize_vars fun ρ => ?_
+  rw [normalize_eval hv, normalize_eval hu]
+  exact h ρ
diff --git a/Lean4Lean/Verify/LevelStd.lean b/Lean4Lean/Verify/LevelStd.lean
new file mode 100644
index 00000000..ca30d7df
--- /dev/null
+++ b/Lean4Lean/Verify/LevelStd.lean
@@ -0,0 +1,540 @@
+import Batteries.Tactic.OpenPrivate
+import Lean4Lean.Theory.VLevel
+import Lean4Lean.Verify.QSort
+import Lean4Lean.Verify.NormLt
+
+open private go in Lean.Level.geq
+open private accMax mkIMaxAux isExplicitSubsumed from Lean.Level
+
+namespace Lean.Level
+
+open Lean4Lean
+
+/-!
+Semantic soundness of the universe-level operations in Lean's standard library.
+`normalize` is an opaque `partial def`, so `Lean4Lean.Verify.Axioms` assumes it
+equals the total copy `Lean.Level.Total.normalize` defined there; the semantic
+behavior of that copy is `eval_normalize` below, which is still open. The exact
+correspondence between `geqCore` below and the private recursion used by
+`Lean.Level.geq` is proved.
+-/
+
+variable (ρ : Name → Nat) (μ : LMVarId → Nat) in
+def eval : Level → Nat
+  | .zero => 0
+  | .param n => ρ n
+  | .mvar n => μ n
+  | .succ l => eval l + 1
+  | .max l₁ l₂ => Nat.max (eval l₁) (eval l₂)
+  | .imax l₁ l₂ => Nat.imax (eval l₁) (eval l₂)
+
+private def offset : Level → Nat
+  | .succ l => offset l + 1
+  | _ => 0
+
+private theorem getOffsetAux_eq_offset :
+    l.getOffsetAux k = offset l + k := by
+  induction l generalizing k with
+  | succ l ih => simp only [Level.getOffsetAux, offset, ih]; omega
+  | _ => simp [Level.getOffsetAux, offset]
+
+private theorem getOffset_eq_offset : l.getOffset = offset l := by
+  simp [Level.getOffset, getOffsetAux_eq_offset]
+
+theorem eval_getLevelOffset :
+    eval ρ μ l = eval ρ μ l.getLevelOffset + l.getOffset := by
+  induction l with | succ l ih => ?_ | _ => rfl
+  simp only [eval, Level.getLevelOffset, getOffset_eq_offset, offset, ih]
+  omega
+
+theorem fallback_sound
+    (h : (u.getLevelOffset = v.getLevelOffset ∨ v.getLevelOffset.isZero = true) ∧
+      v.getOffset ≤ u.getOffset) :
+    eval ρ μ v ≤ eval ρ μ u := by
+  rw [eval_getLevelOffset, eval_getLevelOffset (l := u)]
+  rcases h with ⟨hv | hv, hk⟩
+  · rw [← hv]; omega
+  · have hv : v.getLevelOffset = .zero := by
+      generalize hbase : v.getLevelOffset = base at hv
+      cases base <;> simp_all [Level.isZero]
+    simp [hv, eval]
+    omega
+
+def geqCore : Level → Level → Bool
+  -- Keep this in the same source-shaped form as `go`'s `u == v || ...` prefix.
+  -- The apparently redundant `|| true` is therefore deliberate.
+  | u, .zero => u == .zero || true
+  | u, .max v₁ v₂ => u == .max v₁ v₂ || (geqCore u v₁ && geqCore u v₂)
+  | .max u₁ u₂, .imax v₁ v₂ =>
+    (.max u₁ u₂ : Level) == .imax v₁ v₂ ||
+      (geqCore u₁ (.imax v₁ v₂) || geqCore u₂ (.imax v₁ v₂) ||
+        (geqCore (.max u₁ u₂) v₁ && geqCore (.max u₁ u₂) v₂))
+  | .max u₁ u₂, v =>
+    let u := .max u₁ u₂
+    u == v || (geqCore u₁ v || geqCore u₂ v ||
+      ((u.getLevelOffset == v.getLevelOffset || v.getLevelOffset.isZero) &&
+        u.getOffset ≥ v.getOffset))
+  | .imax u₁ u₂, v => (.imax u₁ u₂ : Level) == v || geqCore u₂ v
+  | .succ u, .succ v => (.succ u : Level) == .succ v || geqCore u v
+  | u, .imax v₁ v₂ => u == .imax v₁ v₂ || (geqCore u v₁ && geqCore u v₂)
+  | u, v => u == v ||
+    ((u.getLevelOffset == v.getLevelOffset || v.getLevelOffset.isZero) &&
+      u.getOffset ≥ v.getOffset)
+  termination_by u v => (u, v)
+
+private theorem geqCore_eq_go : geqCore u v = go u v := by
+  fun_induction go with | _ u v
+  cases u <;> cases v <;> simp_all [geqCore, go]
+
+theorem geqCore_sound (h : geqCore u v) : eval ρ μ v ≤ eval ρ μ u := by
+  induction u, v using geqCore.induct with
+    simp only [geqCore, Bool.or_eq_true, Bool.and_eq_true, beq_iff_eq,
+      decide_eq_true_eq] at h
+  | case1 => simp [eval]
+  | case2 _ _ _ ih₂ ih₁ =>
+    rcases h with rfl | ⟨h₁, h₂⟩
+    · exact Nat.le_refl _
+    · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩
+  | case3 u₁ u₂ v₁ v₂ ih₄ ih₃ ih₂ ih₁ =>
+    rcases h with heq | (h | h) | ⟨h₁, h₂⟩
+    · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm
+    · exact Nat.le_trans (ih₄ h) (Nat.le_max_left ..)
+    · exact Nat.le_trans (ih₃ h) (Nat.le_max_right ..)
+    · simp only [eval, Nat.imax]
+      split
+      · exact Nat.zero_le _
+      · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩
+  | case4 u₁ u₂ v _ _ _ ih₂ ih₁ =>
+    rcases h with rfl | h
+    · exact Nat.le_refl _
+    · rcases h with (h | h) | h
+      · exact Nat.le_trans (ih₂ h) (Nat.le_max_left ..)
+      · exact Nat.le_trans (ih₁ h) (Nat.le_max_right ..)
+      · exact fallback_sound h
+  | case5 u₁ u₂ v _ _ ih =>
+    rcases h with rfl | h
+    · exact Nat.le_refl _
+    · simp only [eval, Nat.imax]
+      have hv := ih h
+      split <;> rename_i hz
+      · simpa [hz] using hv
+      · exact Nat.le_trans hv (Nat.le_max_right ..)
+  | case6 u v ih =>
+    rcases h with heq | h
+    · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm
+    · simpa [eval] using Nat.add_le_add_right (ih h) 1
+  | case7 u v₁ v₂ _ _ ih₂ ih₁ =>
+    rcases h with rfl | ⟨h₁, h₂⟩
+    · exact Nat.le_refl _
+    · simp only [eval, Nat.imax]
+      split
+      · exact Nat.zero_le _
+      · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩
+  | case8 =>
+    rcases h with heq | h
+    · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm
+    · exact fallback_sound h
+
+/-!
+### Soundness of `normalize`
+
+The proof is by strong induction on `Total.size`. The mutual recursion with
+`getMaxArgsAux` is untangled by observing that `getMaxArgsAux l true` recurses only
+structurally, and `getMaxArgsAux l false` calls `normalize` only on levels of size at
+most `size l`, so both can be handled by standalone lemmas parameterized by the
+induction hypothesis for `normalize`.
+
+The `max` branch sorts the collected arguments with `qsort normLt` and then drops
+dominated entries: `mkMaxAux` drops an entry when the next one has the same level base
+(relying on offsets being sorted within a base class), and the explicit (constant)
+entries in the sorted prefix are dropped when subsumed by the largest explicit or by
+some offset to its right. All of this is justified by a single consequence of
+sortedness: entries with equal `getLevelOffset` occur in order of `getOffset`
+(`explicit` entries all have base `zero`, so this also orders the explicit prefix).
+That fact, together with the fact that `qsort` permutes the array, are the only
+properties of sorting used; they are `qsort_perm_toList` and `pairwise_qsort_normLt`
+below, currently unproved because `Array.qsort` has no specification in the standard
+library.
+-/
+
+theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _)
+
+theorem nat_ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m :=
+  Nat.le_antisymm ((H _).2 (Nat.le_refl _)) ((H _).1 (Nat.le_refl _))
+
+theorem eval_addOffset : eval ρ μ (addOffset l k) = eval ρ μ l + k := by
+  suffices ∀ k l, eval ρ μ (addOffsetAux k l) = eval ρ μ l + k from this ..
+  intro k; induction k with intro l
+  | zero => rfl
+  | succ k ih => rw [addOffsetAux, ih]; simp [eval, mkLevelSucc]; omega
+
+theorem isZero_iff : isZero l ↔ l = .zero := by cases l <;> simp [Level.isZero]
+
+theorem isNeverZero_sound (h : l.isNeverZero = true) : 0 < eval ρ μ l := by
+  induction l with
+  | zero | param | mvar => simp [isNeverZero] at h
+  | succ l => simp [eval]
+  | max l₁ l₂ ih₁ ih₂ =>
+    simp only [isNeverZero, Bool.or_eq_true] at h
+    simp only [eval, Nat.max_eq_max]
+    obtain h | h := h
+    · have := ih₁ h; omega
+    · have := ih₂ h; omega
+  | imax l₁ l₂ _ ih₂ =>
+    simp only [isNeverZero] at h
+    have := ih₂ h
+    simp only [eval, Nat.imax, Nat.max_eq_max]; split <;> omega
+
+theorem eval_accMax : eval ρ μ (accMax r p k) = Nat.max (eval ρ μ r) (eval ρ μ p + k) := by
+  rw [accMax]; split <;> rename_i h
+  · rw [isZero_iff.1 h, eval_addOffset]; simp [eval]
+  · simp [mkLevelMax, eval, eval_addOffset]
+
+theorem eval_mkIMaxAux :
+    eval ρ μ (mkIMaxAux a b) = Nat.imax (eval ρ μ a) (eval ρ μ b) := by
+  unfold mkIMaxAux; split
+  · simp [eval, Nat.imax]
+  · simp only [eval, Nat.imax]; split <;> [omega; simp]
+  · simp only [eval, Nat.imax, Nat.max_eq_max]; split <;> [omega; rw [Nat.max_eq_right (by omega)]]
+  · split <;> rename_i h
+    · cases eq_of_beq h; simp only [Nat.imax, Nat.max_eq_max]
+      split <;> [omega; rw [Nat.max_self]]
+    · simp [mkLevelIMax, eval]
+
+/-- The maximum of the evaluations of a list of levels. -/
+def evalList (ρ : Name → Nat) (μ : LMVarId → Nat) (ls : List Level) : Nat :=
+  ls.foldr (fun l n => Nat.max (eval ρ μ l) n) 0
+
+theorem evalList_le_iff : evalList ρ μ ls ≤ n ↔ ∀ l ∈ ls, eval ρ μ l ≤ n := by
+  induction ls with
+  | nil => simp [evalList, Nat.zero_le]
+  | cons l ls ih =>
+    show Nat.max (eval ρ μ l) (evalList ρ μ ls) ≤ n ↔ _
+    rw [Nat.max_eq_max, Nat.max_le, ih]; simp
+
+theorem le_evalList (h : l ∈ ls) : eval ρ μ l ≤ evalList ρ μ ls :=
+  evalList_le_iff.1 (Nat.le_refl _) _ h
+
+theorem evalList_perm (h : ls₁.Perm ls₂) : evalList ρ μ ls₁ = evalList ρ μ ls₂ := by
+  refine nat_ext_le fun _ => ?_; simp only [evalList_le_iff, h.mem_iff]
+
+theorem evalList_append : evalList ρ μ (ls₁ ++ ls₂) =
+    Nat.max (evalList ρ μ ls₁) (evalList ρ μ ls₂) := by
+  induction ls₁ with | nil => simp [evalList] | cons l ls ih
+  show Nat.max _ (evalList ρ μ (ls ++ ls₂)) = Nat.max (Nat.max _ (evalList ρ μ ls)) _
+  rw [ih]; simp only [Nat.max_eq_max]; rw [Nat.max_assoc]
+
+/-- `Array.qsort` returns a permutation of its input (`Array.qsort_perm`). -/
+theorem qsort_perm (as : Array Level) : (as.qsort normLt).toList.Perm as.toList :=
+  Array.perm_iff_toList_perm.1 (Array.qsort_perm normLt 0 (as.size - 1) as)
+
+/-- Entries with equal level base come out of `qsort normLt` ordered by offset: a
+consequence of sortedness (`Array.qsort_sorted`), since `normLt` compares levels with
+equal bases by offset. -/
+theorem pairwise_qsort (as : Array Level) :
+    (as.qsort normLt).toList.Pairwise fun a b =>
+      a.getLevelOffset = b.getLevelOffset → a.getOffset ≤ b.getOffset := by
+  rw [List.pairwise_iff_getElem]
+  intro i j hi hj hij hb
+  simp only [Array.getElem_toList] at hb
+  simpa [normLt_same_base hb.symm] using
+    Array.qsort_sorted normLt normLt_asymm normLt_le_trans as i j hij hj
+
+theorem offset_le_eval : l.getOffset ≤ eval ρ μ l := by
+  rw [eval_getLevelOffset]; omega
+
+theorem eval_of_isZero (h : l.getLevelOffset.isZero) : eval ρ μ l = l.getOffset := by
+  rw [eval_getLevelOffset, isZero_iff.1 h]; simp [eval]
+
+theorem skipExplicit_spec {lvls : Array Level} : i ≤ lvls.size →
+    i ≤ Total.skipExplicit lvls i ∧ Total.skipExplicit lvls i ≤ lvls.size ∧
+    ∀ j (_ : j < lvls.size), i ≤ j → j < Total.skipExplicit lvls i →
+      lvls[j].getLevelOffset.isZero := by
+  fun_induction Total.skipExplicit lvls i with
+  | case1 i hi hz ih =>
+    intro h
+    obtain ⟨ih1, ih2, ih3⟩ := ih (by omega)
+    refine ⟨by omega, ih2, fun j hj hij hlt => ?_⟩
+    rcases Nat.eq_or_lt_of_le hij with rfl | hij'
+    · exact hz
+    · exact ih3 j hj (by omega) hlt
+  | case2 i hi hz => exact fun h => ⟨Nat.le_refl _, by omega, fun j hj hij hlt => by omega⟩
+  | case3 i hi => exact fun h => ⟨Nat.le_refl _, by omega, fun j hj hij hlt => by omega⟩
+
+theorem isExplicitSubsumedAux_spec {lvls : Array Level} :
+    Total.isExplicitSubsumedAux lvls mx i = true ↔
+      ∃ j, i ≤ j ∧ ∃ (_ : j < lvls.size), mx ≤ lvls[j].getOffset := by
+  fun_induction Total.isExplicitSubsumedAux lvls mx i with
+  | case1 i hi hge => simpa using ⟨i, Nat.le_refl _, hi, by omega⟩
+  | case2 i hi hlt ih =>
+    rw [ih]
+    constructor <;> rintro ⟨j, hij, hj, hle⟩ <;> refine ⟨j, ?_, hj, hle⟩
+    · omega
+    · obtain rfl | h := Nat.eq_or_lt_of_le hij <;> omega
+  | case3 i hi => simp; rintro j hij hj; omega
+
+theorem eval_mkMaxAux {lvls : Array Level}
+    (hs : ∀ (i j : Nat) (hi : i < lvls.size) (hj : j < lvls.size), i < j →
+      lvls[i].getLevelOffset = lvls[j].getLevelOffset → lvls[i].getOffset ≤ lvls[j].getOffset)
+    (hfuel : lvls.size ≤ i + fuel)
+    (hi0 : 0 < i) (hile : i ≤ lvls.size)
+    (hp : ∀ h : i - 1 < lvls.size, prev = lvls[i-1].getLevelOffset ∧ prevK = lvls[i-1].getOffset) :
+    eval ρ μ (Total.mkMaxAux lvls extraK i prev prevK result) =
+      Nat.max (eval ρ μ result) (evalList ρ μ (lvls.toList.drop (i-1)) + extraK) := by
+  induction fuel generalizing i result prev prevK with
+  | zero =>
+    have hie : i = lvls.size := by omega
+    obtain ⟨hp, hpk⟩ := hp (by omega)
+    rw [Total.mkMaxAux.eq_def, dif_neg (by omega), eval_accMax]
+    have hlast : i - 1 < lvls.size := by omega
+    have hdrop : lvls.toList.drop (i-1) = [lvls[i-1]] := by
+      rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)]
+      simp [hie]; omega
+    have : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by
+      rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk]
+    rw [hdrop]
+    simp only [evalList, List.foldr_cons, List.foldr_nil, this, Nat.max_eq_max]
+    omega
+  | succ fuel ih =>
+    rw [Total.mkMaxAux.eq_def]
+    split <;> rename_i hlt
+    · obtain ⟨hp, hpk⟩ := hp (by omega)
+      have hlast : i - 1 < lvls.size := by omega
+      have hdrop : lvls.toList.drop (i-1) = lvls[i-1] :: lvls.toList.drop i := by
+        rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)]
+        simp; congr 1; omega
+      have heval : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by
+        rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk]
+      have hmem : eval ρ μ lvls[i] ≤ evalList ρ μ (lvls.toList.drop i) :=
+        le_evalList (by rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)]; exact .head _)
+      dsimp only
+      split <;> rename_i hbeq
+      · -- equal bases: drop the previous entry
+        rw [ih (i := i+1) (by omega) (by omega) (by omega) (fun h => by simp)]
+        have hb : lvls[i].getLevelOffset = prev := eq_of_beq hbeq
+        have hk : prevK ≤ lvls[i].getOffset := by
+          rw [hpk]; exact hs (i-1) i hlast hlt (by omega) (by rw [hb, hp])
+        have hle : eval ρ μ lvls[i-1] ≤ evalList ρ μ (lvls.toList.drop i) := by
+          refine Nat.le_trans ?_ hmem
+          rw [heval, eval_getLevelOffset (l := lvls[i]), hb, hp]
+          omega
+        rw [Nat.add_sub_cancel, hdrop]
+        have : evalList ρ μ (lvls[i-1] :: lvls.toList.drop i) =
+            evalList ρ μ (lvls.toList.drop i) := by
+          exact Nat.max_eq_right hle
+        rw [this]
+      · -- new base: accumulate the previous entry
+        rw [ih (i := i+1) (by omega) (by omega) (by omega) (fun h => by simp)]
+        rw [Nat.add_sub_cancel, eval_accMax, hdrop]
+        simp only [evalList, List.foldr_cons, Nat.max_eq_max, heval]
+        omega
+    · have hie : i = lvls.size := by omega
+      obtain ⟨hp, hpk⟩ := hp (by omega)
+      rw [eval_accMax]
+      have hlast : i - 1 < lvls.size := by omega
+      have hdrop : lvls.toList.drop (i-1) = [lvls[i-1]] := by
+        rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)]
+        simp [hie]; omega
+      have : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by
+        rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk]
+      rw [hdrop]
+      simp only [evalList, List.foldr_cons, List.foldr_nil, this, Nat.max_eq_max]
+      omega
+
+theorem size_lt_getMaxArgsAux_true :
+    lvls.size < (Total.getMaxArgsAux l true lvls).size := by
+  induction l generalizing lvls with
+  | max _ _ ih₁ ih₂ => exact Total.getMaxArgsAux.eq_def .. ▸ Nat.lt_trans ih₁ ih₂
+  | _ => rw [Total.getMaxArgsAux.eq_def]; simp
+
+theorem size_lt_getMaxArgsAux_false :
+    lvls.size < (Total.getMaxArgsAux l false lvls).size := by
+  induction l generalizing lvls with
+  | max _ _ ih₁ ih₂ => exact Total.getMaxArgsAux.eq_def .. ▸ Nat.lt_trans ih₁ ih₂
+  | _ => exact Total.getMaxArgsAux.eq_def .. ▸ size_lt_getMaxArgsAux_true ..
+
+theorem evalList_getMaxArgsAux_true :
+    evalList ρ μ (Total.getMaxArgsAux l true lvls).toList =
+      Nat.max (evalList ρ μ lvls.toList) (eval ρ μ l) := by
+  induction l generalizing lvls with
+  | max l₁ l₂ ih₁ ih₂ =>
+    rw [Total.getMaxArgsAux, ih₂, ih₁]
+    simp only [eval, Nat.max_eq_max]; omega
+  | _ =>
+    rw [Total.getMaxArgsAux.eq_def, Array.toList_push, evalList_append]
+    simp only [evalList, List.foldr_cons, List.foldr_nil, Nat.max_eq_max]; omega
+
+theorem evalList_getMaxArgsAux_false {l : Level}
+    (IH : ∀ u, Total.size u ≤ Total.size l → eval ρ μ (Total.normalize u) = eval ρ μ u) :
+    evalList ρ μ (Total.getMaxArgsAux l false lvls).toList =
+      Nat.max (evalList ρ μ lvls.toList) (eval ρ μ l) := by
+  induction l generalizing lvls with
+  | max l₁ l₂ ih₁ ih₂ =>
+    rw [Total.getMaxArgsAux.eq_def]
+    show evalList ρ μ (Total.getMaxArgsAux l₂ false (Total.getMaxArgsAux l₁ false lvls)).toList = _
+    rw [ih₂ (fun u hu => IH u (by simp only [Total.size] at *; omega)),
+      ih₁ (fun u hu => IH u (by simp only [Total.size] at *; omega))]
+    simp only [eval, Nat.max_eq_max]; omega
+  | _ => rw [Total.getMaxArgsAux.eq_def, evalList_getMaxArgsAux_true, IH _ (Nat.le_refl _)]
+
+/-- Dropping a dominated prefix does not change the maximum. -/
+theorem evalList_drop_eq {ls : List Level} (hstart : start ≤ ls.length)
+    (hdom : ∀ j (hj : j < ls.length), j < start →
+      eval ρ μ ls[j] ≤ evalList ρ μ (ls.drop start)) :
+    evalList ρ μ (ls.drop start) = evalList ρ μ ls := by
+  refine nat_ext_le fun n => ?_
+  simp only [evalList_le_iff]
+  constructor <;> intro H l hl
+  · obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.1 hl
+    by_cases hjs : j < start
+    · exact Nat.le_trans (hdom j hj hjs) (evalList_le_iff.2 H)
+    · refine H _ (List.mem_iff_getElem.2 ⟨j - start, by simp; omega, ?_⟩)
+      rw [List.getElem_drop]; congr 1; omega
+  · exact H l (List.drop_subset _ _ hl)
+
+/-- The level base of a level that is not already normalized is a `max` or an `imax`. -/
+theorem base_of_not_cheap {l : Level} (h : ¬l.isAlreadyNormalizedCheap = true) :
+    (∃ a b, l.getLevelOffset = .max a b) ∨ (∃ a b, l.getLevelOffset = .imax a b) := by
+  induction l with
+  | succ l ih => apply ih; simpa [isAlreadyNormalizedCheap] using h
+  | max l₁ l₂ => exact .inl ⟨_, _, rfl⟩
+  | imax l₁ l₂ => exact .inr ⟨_, _, rfl⟩
+  | _ => simp [isAlreadyNormalizedCheap] at h
+
+theorem eval_normalize_total {l : Level} : eval ρ μ (Total.normalize l) = eval ρ μ l := by
+  generalize hn : Total.size l = n
+  induction n using Nat.strongRecOn generalizing l with | _ n IH
+  subst hn
+  rw [Total.normalize.eq_def]
+  split <;> [rfl; rename_i hcheap]
+  have hsz := Total.size_getLevelOffset l
+  split <;> [rename_i l₁ l₂ hbase; rename_i l₁ l₂ hbase; skip]
+  · -- max
+    rw [eval_getLevelOffset (l := l), hbase]
+    rw [hbase] at hsz; simp only [Total.size] at hsz
+    have hs₁ := Total.one_le_size l₁
+    have hs₂ := Total.one_le_size l₂
+    have IH₁ u (hu : Total.size u ≤ Total.size l₁) : eval ρ μ (Total.normalize u) = eval ρ μ u :=
+      IH _ (by omega) rfl
+    have IH₂ u (hu : Total.size u ≤ Total.size l₂) : eval ρ μ (Total.normalize u) = eval ρ μ u :=
+      IH _ (by omega) rfl
+    extract_lets k lvls₁ L1 L i₀ i lvl₁ prev prevK
+    have hevalL1 : evalList ρ μ L1.toList = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) := by
+      rw [evalList_getMaxArgsAux_false IH₂, evalList_getMaxArgsAux_false IH₁]
+      simp [evalList, Nat.max_eq_max]
+    have hL1pos : 0 < L1.size :=
+      Nat.lt_trans (size_lt_getMaxArgsAux_false (lvls := #[])) size_lt_getMaxArgsAux_false
+    have hperm : L.toList.Perm L1.toList := qsort_perm L1
+    have hpair : List.Pairwise _ L.toList := pairwise_qsort L1
+    have hLsize : L.size = L1.size := by
+      simpa [Array.length_toList] using hperm.length_eq
+    have hLpos : 0 < L.size := hLsize ▸ hL1pos
+    have hevalL : evalList ρ μ L.toList = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) := by
+      rw [evalList_perm hperm, hevalL1]
+    have hs : ∀ (i j : Nat) (hi : i < L.size) (hj : j < L.size), i < j →
+        L[i].getLevelOffset = L[j].getLevelOffset → L[i].getOffset ≤ L[j].getOffset := by
+      intro i j hi hj hij hb
+      have := (List.pairwise_iff_getElem.1 hpair) i j (by simpa using hi) (by simpa using hj) hij
+      simpa using this (by simpa using hb)
+    obtain ⟨-, hskle, hskz⟩ := skipExplicit_spec (lvls := L) (i := 0) (Nat.zero_le _)
+    -- the start index and its bound
+    have main i (hi : i < L.size)
+        (hdom : ∀ j (hj : j < L.size), j < i → eval ρ μ L[j] ≤ evalList ρ μ (L.toList.drop i)) :
+        eval ρ μ (Total.mkMaxAux L (l.getOffset) (i+1) L[i]!.getLevelOffset L[i]!.getOffset
+          Level.zero) = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) + l.getOffset := by
+      rw [getElem!_pos L i hi,
+        eval_mkMaxAux hs (fuel := L.size) (by omega) (by omega) (by omega) (fun _ => by simp),
+        Nat.add_sub_cancel, evalList_drop_eq (by rw [Array.length_toList]; omega) hdom, hevalL]
+      simp [eval, Nat.max_eq_max]
+    subst i lvl₁ prevK prev; split <;> rename_i hsub
+    · -- explicits subsumed: start at the first non-explicit
+      rw [isExplicitSubsumed] at hsub
+      split at hsub <;> [cases hsub; let (eq := eq) i'+1 := i₀]; subst i₀
+      simp only [isExplicitSubsumedAux_eq, isExplicitSubsumedAux_spec] at hsub
+      obtain ⟨j, hij, hjs, hmax⟩ := hsub; dsimp at hmax
+      refine main (i'+1) (by omega) fun m hm hmi => ?_
+      -- every dropped explicit is at most the witness entry
+      have hzm : L[m].getLevelOffset.isZero := hskz m hm (Nat.zero_le _) (eq ▸ hmi)
+      have hz₁ := hskz i' (by omega) (Nat.zero_le _) (by omega)
+      have h2 : L[m].getOffset ≤ L[i'].getOffset := by
+        rcases Nat.eq_or_lt_of_le (Nat.le_pred_of_lt hmi) with h | h
+        · subst h; exact Nat.le_refl _
+        · exact hs m i' hm (by omega) h (by rw [isZero_iff.1 hzm, isZero_iff.1 hz₁])
+      have h3 : L[i'].getOffset ≤ eval ρ μ L[j] :=
+        Nat.le_trans (getElem!_pos L i' (by omega) ▸ hmax) offset_le_eval
+      refine eval_of_isZero hzm ▸ Nat.le_trans (Nat.le_trans h2 h3) (le_evalList ?_)
+      refine List.mem_iff_getElem.2 ⟨j - (i' + 1), ?_, ?_⟩
+      · simp only [List.length_drop, Array.length_toList]; omega
+      · rw [List.getElem_drop]; simp only [Array.getElem_toList]; congr 1; omega
+    · -- keep the largest explicit
+      cases eq : i₀ with | zero => exact main 0 (by omega) (fun m hm hmi => by omega) | succ i'
+      have hstart : i' < L.size := by omega
+      refine main i' hstart fun m hm hmi => ?_
+      have hzm : L[m].getLevelOffset.isZero := hskz m hm (Nat.zero_le _) (by omega)
+      have hz₁ : L[i'].getLevelOffset.isZero :=
+        hskz i' hstart (Nat.zero_le _) (by omega)
+      refine eval_of_isZero hzm ▸ Nat.le_trans (hs m i' hm hstart (by omega) ?_) ?_
+      · rw [isZero_iff.1 hzm, isZero_iff.1 hz₁]
+      refine eval_of_isZero hz₁ ▸ le_evalList ?_
+      rw [List.drop_eq_getElem_cons (by omega)]; exact .head _
+  · -- imax
+    rw [eval_getLevelOffset (l := l), hbase]
+    rw [hbase] at hsz; simp only [Total.size] at hsz
+    have hs₁ := Total.one_le_size l₁
+    have hs₂ := Total.one_le_size l₂
+    split <;> rename_i hnz
+    · rw [eval_addOffset, IH (Total.size (mkLevelMax l₁ l₂))
+        (by simp only [mkLevelMax, Total.size]; omega) rfl]
+      have := isNeverZero_sound (ρ := ρ) (μ := μ) hnz
+      simp only [mkLevelMax, eval, Nat.imax]
+      rw [if_neg (by omega)]
+    · rw [eval_addOffset, eval_mkIMaxAux, IH _ (by omega) rfl, IH _ (by omega) rfl]; rfl
+  · grind [base_of_not_cheap]
+
+theorem eval_normalize {ρ μ l} : eval ρ μ l.normalize = eval ρ μ l := by
+  rw [normalize_eq]; exact eval_normalize_total
+
+theorem geq_eq_core : geq u v = geqCore (normalize u) (normalize v) := by
+  simp [geq, geqCore_eq_go]
+
+theorem isEquiv_sound (h : isEquiv u v) : eval ρ μ u = eval ρ μ v := by
+  simp only [Level.isEquiv, Bool.or_eq_true, beq_iff_eq] at h
+  rcases h with rfl | h <;> [rfl; skip]
+  rw [← eval_normalize (l := u), ← eval_normalize (l := v), h]
+
+theorem geq_sound (h : geq u v) : eval ρ μ v ≤ eval ρ μ u := by
+  rw [geq_eq_core] at h
+  rw [← eval_normalize (l := u), ← eval_normalize (l := v)]
+  exact geqCore_sound h
+
+theorem eval_ofLevel (h : VLevel.ofLevel Us l = some l') :
+    l'.eval ns = eval (fun n => ns.getD (Us.idxOf n) 0) μ l := by
+  induction l generalizing l' with
+  | zero => simp [VLevel.ofLevel] at h; cases h; rfl
+  | succ l ih =>
+    simp [VLevel.ofLevel, bind] at h
+    obtain ⟨l', hl, rfl⟩ := h
+    simp [VLevel.eval, eval, ih hl]
+  | max l₁ l₂ ih₁ ih₂ | imax l₁ l₂ ih₁ ih₂ =>
+    simp [VLevel.ofLevel, bind] at h
+    obtain ⟨l₁', hl₁, l₂', hl₂, rfl⟩ := h
+    simp [VLevel.eval, eval, ih₁ hl₁, ih₂ hl₂]
+  | param n =>
+    simp [VLevel.ofLevel] at h
+    obtain ⟨hidx, rfl⟩ := h
+    simp [VLevel.eval, eval]
+  | mvar n => simp [VLevel.ofLevel] at h
+
+theorem isEquiv_wf (h : isEquiv u v)
+    (hu : VLevel.ofLevel Us u = some u') (hv : VLevel.ofLevel Us v = some v') : u' ≈ v' := by
+  refine VLevel.equiv_def.2 fun ns => ?_
+  rw [eval_ofLevel (μ := fun _ => 0) hu, eval_ofLevel (μ := fun _ => 0) hv]
+  exact isEquiv_sound h
+
+theorem geq_wf (h : geq u v)
+    (hu : VLevel.ofLevel Us u = some u') (hv : VLevel.ofLevel Us v = some v') : v' ≤ u' := by
+  intro ns
+  rw [eval_ofLevel (μ := fun _ => 0) hv, eval_ofLevel (μ := fun _ => 0) hu]
+  exact geq_sound h
+
+end Lean.Level
diff --git a/Lean4Lean/Verify/Name.lean b/Lean4Lean/Verify/Name.lean
new file mode 100644
index 00000000..05dee4ee
--- /dev/null
+++ b/Lean4Lean/Verify/Name.lean
@@ -0,0 +1,90 @@
+import Lean.Data.NameMap.Basic
+import Lean4Lean.Std.Ord
+import Std.Data.TreeSet.Lemmas
+
+/-!
+Order properties of `Lean.Name.cmp` and `Lean.Name.quickCmp`.
+-/
+
+namespace Lean
+
+namespace Name
+open _root_.Std Lean4Lean
+
+theorem cmp_eq_swap {a b : Name} : a.cmp b = (b.cmp a).swap := by
+  induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp]
+  | str a₁ a₂ ih | num a₁ a₂ ih =>
+    rw [ih]; cases b₁.cmp a₁ <;> simp [← OrientedOrd.eq_swap]
+
+instance : TransCmp cmp := by
+  refine TransCmp.of_rot (fun _ _ => cmp_eq_swap) fun a b c => ?_
+  induction a generalizing b c with
+  | anonymous =>
+    obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [cmp, Rot]
+  | str a₁ a₂ ih | num a₁ a₂ ih =>
+    obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;>
+      first
+      | exact (ih ..).then (Rot.of_transCmp ..)
+      | simp [cmp, Rot]
+
+instance : LawfulBEqCmp cmp where
+  compare_eq_iff_beq {a b} := by
+    simp; refine ⟨?_, fun h => h ▸ ReflCmp.compare_self⟩
+    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp]
+    | str a₁ a₂ ih | num a₁ a₂ ih =>
+      refine ?_ ∘ Ordering.then_eq_eq.1
+      simp +contextual; exact fun h _ => ih h
+
+instance : TransCmp quickCmp where
+  eq_swap {a b} := by
+    simp [quickCmp]
+    rw [OrientedOrd.eq_swap]
+    cases compare b.hash a.hash <;> simp
+    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux]
+    | str a₁ a₂ ih | num a₁ a₂ ih =>
+      rw [OrientedOrd.eq_swap]
+      cases compare b₂ a₂ <;> simp [ih]
+  isLE_trans {a b c} := by
+    have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁ : α} {a₂ b₂ c₂}
+        (H : (quickCmpAux a₂ b₂).isLE → (quickCmpAux b₂ c₂).isLE → (quickCmpAux a₂ c₂).isLE) :
+        ((compare a₁ b₁).then (quickCmpAux a₂ b₂)).isLE →
+        ((compare b₁ c₁).then (quickCmpAux b₂ c₂)).isLE →
+        ((compare a₁ c₁).then (quickCmpAux a₂ c₂)).isLE := by
+      simp [Ordering.isLE_then_iff_and]
+      intro h1 h2 h3 h4
+      refine ⟨TransCmp.isLE_trans h1 h3, ?_⟩
+      refine h2.elim (fun h2 => .inl <| TransCmp.lt_of_lt_of_isLE h2 h3) fun h2 => ?_
+      refine h4.elim (fun h4 => .inl <| TransCmp.lt_of_isLE_of_lt h1 h4) fun h4 => .inr (H h2 h4)
+    apply this
+    induction a generalizing b c with
+      obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] at * <;>
+      obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [quickCmpAux] at *
+    | str a₁ a₂ ih | num a₁ a₂ ih => apply this ih
+
+instance : LawfulBEqCmp quickCmp where
+  compare_eq_iff_beq {a b} := by
+    simp; refine ⟨fun h => ?_, fun h => h ▸ ReflCmp.compare_self⟩
+    replace h := (Ordering.then_eq_eq.1 h).2; revert h
+    induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux]
+    | str a₁ a₂ ih | num a₁ a₂ ih =>
+      refine ?_ ∘ Ordering.then_eq_eq.1
+      simp +contextual; exact fun _ => ih
+
+end Name
+
+namespace NameSet
+open _root_.Std
+
+theorem contains_insert {s : NameSet} {a b : Name} :
+    (s.insert a).contains b = (a == b || s.contains b) := by
+  have key : (Name.quickCmp a b == Ordering.eq) = (a == b) := by
+    have := @LawfulBEqCmp.compare_eq_iff_beq _ _ Name.quickCmp _ a b
+    cases h : Name.quickCmp a b <;> simp_all
+  have h : (s.insert a).contains b
+      = (Name.quickCmp a b == Ordering.eq || s.contains b) :=
+    Std.TreeSet.contains_insert (t := s) (k := a) (a := b)
+  rw [h, key]
+
+@[simp] theorem contains_empty {a : Name} : (∅ : NameSet).contains a = false := rfl
+
+end NameSet
diff --git a/Lean4Lean/Verify/NormLt.lean b/Lean4Lean/Verify/NormLt.lean
new file mode 100644
index 00000000..446ee0fd
--- /dev/null
+++ b/Lean4Lean/Verify/NormLt.lean
@@ -0,0 +1,364 @@
+import Lean.Level
+import Lean4Lean.Verify.Name
+import Lean4Lean.Std.Ord
+import Lean4Lean.Verify.Axioms
+
+/-!
+`Lean.Level.normLt` is the order used to sort the arguments of a `max` in
+`Lean.Level.normalize`. This file shows it is a strict weak order, which is what the
+`Array.qsort` specification requires.
+
+The proof identifies `normLt` with an `Ordering`-valued comparison `normCmp`, which compares
+levels by (base, offset) lexicographically, bases being compared structurally. `normCmp` is
+then given the `Std` order instances (`ReflCmp`, `TransCmp`, `LawfulEqCmp`), from which the
+strict weak order properties `normLt` needs follow. Transitivity uses `Lean4Lean.Rot`, the
+lexicographic-product device shared with `Name.cmp` in `Lean4Lean.Verify.Name`.
+-/
+
+open Std Lean4Lean
+
+namespace Lean.Level
+
+instance : LawfulBEq LMVarId where
+  eq_of_beq := @fun ⟨a⟩ ⟨b⟩ h => by cases LawfulBEq.eq_of_beq (α := Name) h; rfl
+  rfl := BEq.rfl (α := Name)
+
+/-- The structural size of a level. -/
+private def size : Level → Nat
+  | .zero | .param _ | .mvar _ => 1
+  | .succ l => size l + 1
+  | .max a b | .imax a b => size a + size b + 1
+
+private theorem size_max {a b : Level} : size (.max a b) = size a + size b + 1 := rfl
+private theorem size_imax {a b : Level} : size (.imax a b) = size a + size b + 1 := rfl
+
+private theorem one_le_size : ∀ l : Level, 1 ≤ size l
+  | .zero | .param _ | .mvar _ => Nat.le_refl _
+  | .succ l => Nat.le_succ_of_le (one_le_size l)
+  | .max a b | .imax a b => by have := one_le_size a; simp only [size]; omega
+
+private theorem size_getLevelOffset_le : ∀ l : Level, size l.getLevelOffset ≤ size l
+  | .succ l => Nat.le_trans (size_getLevelOffset_le l) (Nat.le_succ _)
+  | .zero | .param _ | .mvar _ | .max .. | .imax .. => Nat.le_refl _
+
+/-- Structural comparison of level *bases* (levels that are not `succ`s).
+Sub-levels are compared by `normCmp`, i.e. base first, then offset. -/
+def baseCmp : Level → Level → Ordering
+  | .max a b, .max c d =>
+    ((baseCmp a.getLevelOffset c.getLevelOffset).then (compare a.getOffset c.getOffset)).then
+      ((baseCmp b.getLevelOffset d.getLevelOffset).then (compare b.getOffset d.getOffset))
+  | .imax a b, .imax c d =>
+    ((baseCmp a.getLevelOffset c.getLevelOffset).then (compare a.getOffset c.getOffset)).then
+      ((baseCmp b.getLevelOffset d.getLevelOffset).then (compare b.getOffset d.getOffset))
+  | .param n₁, .param n₂ => Name.cmp n₁ n₂
+  | .mvar n₁, .mvar n₂ => Name.cmp n₁.name n₂.name
+  | l₁, l₂ => compare l₁.ctorToNat l₂.ctorToNat
+termination_by l₁ l₂ => size l₁ + size l₂
+decreasing_by
+  all_goals
+    first
+    | (exact Nat.lt_of_le_of_lt
+        (Nat.add_le_add (size_getLevelOffset_le _) (size_getLevelOffset_le _))
+        (by simp only [size]; omega))
+
+/-- Comparison of levels: base first, then offset. -/
+def normCmp (l₁ l₂ : Level) : Ordering :=
+  (baseCmp l₁.getLevelOffset l₂.getLevelOffset).then (compare l₁.getOffset l₂.getOffset)
+
+/-- The same-constructor part of `baseCmp`. It is `.eq` when the constructors differ, in which
+case the `ctorToNat` comparison of `baseCmp_eq` already decides the comparison. -/
+private def structCmp : Level → Level → Ordering
+  | .max a b, .max c d => (normCmp a c).then (normCmp b d)
+  | .imax a b, .imax c d => (normCmp a c).then (normCmp b d)
+  | .param n₁, .param n₂ => Name.cmp n₁ n₂
+  | .mvar n₁, .mvar n₂ => Name.cmp n₁.name n₂.name
+  | _, _ => .eq
+
+/-- `baseCmp` is the lexicographic product of the constructor tags with `structCmp`. -/
+private theorem baseCmp_eq : ∀ l₁ l₂ : Level,
+    baseCmp l₁ l₂ = (compare l₁.ctorToNat l₂.ctorToNat).then (structCmp l₁ l₂) := by
+  intro l₁ l₂
+  cases l₁ <;> cases l₂ <;> simp [baseCmp, structCmp, normCmp, ctorToNat]
+
+private theorem baseCmp_swap : ∀ l₁ l₂ : Level, baseCmp l₂ l₁ = (baseCmp l₁ l₂).swap := by
+  intro l₁ l₂
+  induction l₁, l₂ using baseCmp.induct with
+  | case1 a b c d ih₁ ih₂ | case2 a b c d ih₁ ih₂ =>
+    rw [baseCmp, baseCmp]
+    simp only [Ordering.swap_then]
+    rw [← ih₁, ← ih₂,
+      ← OrientedCmp.eq_swap (cmp := compare (α := Nat)) (a := c.getOffset) (b := a.getOffset),
+      ← OrientedCmp.eq_swap (cmp := compare (α := Nat)) (a := d.getOffset) (b := b.getOffset)]
+  | case3 n₁ n₂ | case4 n₁ n₂ =>
+    rw [baseCmp, baseCmp]; exact OrientedCmp.eq_swap
+  | case5 l₁ l₂ h₁ h₂ h₃ h₄ =>
+    rw [baseCmp, baseCmp]
+    · exact OrientedCmp.eq_swap
+    all_goals grind
+
+theorem normCmp_swap (l₁ l₂ : Level) : normCmp l₂ l₁ = (normCmp l₁ l₂).swap := by
+  rw [normCmp, normCmp, Ordering.swap_then, ← baseCmp_swap,
+    ← OrientedCmp.eq_swap (cmp := compare (α := Nat))]
+
+private theorem normCmp_rot_of {a b c : Level}
+    (h : Rot (baseCmp a.getLevelOffset b.getLevelOffset)
+      (baseCmp b.getLevelOffset c.getLevelOffset) (baseCmp a.getLevelOffset c.getLevelOffset)) :
+    Rot (normCmp a b) (normCmp b c) (normCmp a c) :=
+  h.then (Rot.of_transCmp a.getOffset b.getOffset c.getOffset)
+
+private theorem baseCmp_rot : ∀ l₁ l₂ l₃ : Level,
+    Rot (baseCmp l₁ l₂) (baseCmp l₂ l₃) (baseCmp l₁ l₃) := by
+  suffices key : ∀ n l₁ l₂ l₃, size l₁ + size l₂ + size l₃ ≤ n →
+      Rot (baseCmp l₁ l₂) (baseCmp l₂ l₃) (baseCmp l₁ l₃) from
+    fun l₁ l₂ l₃ => key _ l₁ l₂ l₃ (Nat.le_refl _)
+  intro n
+  induction n with
+  | zero =>
+    intro l₁ l₂ l₃ h
+    have := one_le_size l₁; have := one_le_size l₂; have := one_le_size l₃
+    omega
+  | succ n ih =>
+    intro l₁ l₂ l₃ hn
+    rw [baseCmp_eq, baseCmp_eq, baseCmp_eq]
+    refine (Rot.of_transCmp ..).then' fun e₁ e₂ e₃ => ?_
+    -- the sub-level comparisons are on strictly smaller levels
+    have small : ∀ x y z : Level, size x + size y + size z < size l₁ + size l₂ + size l₃ →
+        Rot (normCmp x y) (normCmp y z) (normCmp x z) := by
+      intro x y z hxyz
+      refine normCmp_rot_of (ih _ _ _ ?_)
+      have := size_getLevelOffset_le x
+      have := size_getLevelOffset_le y
+      have := size_getLevelOffset_le z
+      omega
+    -- all three constructor tags agree, so all three levels share a constructor
+    have hc₁ : l₁.ctorToNat = l₂.ctorToNat := Nat.compare_eq_eq.1 e₁
+    have hc₂ : l₂.ctorToNat = l₃.ctorToNat := Nat.compare_eq_eq.1 e₂
+    clear e₁ e₂ e₃ hn
+    cases l₁ <;> cases l₂ <;> cases hc₁ <;> cases l₃ <;> cases hc₂ <;> simp only [structCmp]
+    · exact ⟨fun _ _ => rfl, fun _ _ => rfl, fun _ _ => rfl⟩
+    · exact ⟨fun _ _ => rfl, fun _ _ => rfl, fun _ _ => rfl⟩
+    · refine Rot.then (small _ _ _ ?_) (small _ _ _ ?_) <;> (simp only [size_max]; omega)
+    · refine Rot.then (small _ _ _ ?_) (small _ _ _ ?_) <;> (simp only [size_imax]; omega)
+    · exact Rot.of_transCmp ..
+    · exact Rot.of_transCmp ..
+
+theorem normCmp_rot (a b c : Level) : Rot (normCmp a b) (normCmp b c) (normCmp a c) :=
+  normCmp_rot_of (baseCmp_rot ..)
+
+instance : TransCmp baseCmp := TransCmp.of_rot (fun a b => baseCmp_swap b a) baseCmp_rot
+instance : TransCmp normCmp := TransCmp.of_rot (fun a b => normCmp_swap b a) normCmp_rot
+
+private theorem getOffsetAux_eq : ∀ (l : Level) (k), l.getOffsetAux k = l.getOffset + k := by
+  intro l
+  induction l with
+  | succ l ih =>
+    intro k
+    show l.getOffsetAux (k+1) = l.getOffsetAux 1 + k
+    rw [ih (k+1), ih 1]; omega
+  | _ => intro k; simp [getOffsetAux, getOffset]
+
+private theorem getOffset_succ {l : Level} : (Level.succ l).getOffset = l.getOffset + 1 := by
+  show l.getOffsetAux 1 = _
+  rw [getOffsetAux_eq]
+
+private theorem getLevelOffset_succ {l : Level} :
+    (Level.succ l).getLevelOffset = l.getLevelOffset := rfl
+
+/-! ### Reflexivity and antisymmetry -/
+
+private theorem baseCmp_refl : ∀ l : Level, baseCmp l l = .eq := by
+  suffices key : ∀ n l, size l ≤ n → baseCmp l l = .eq from fun l => key _ l (Nat.le_refl _)
+  intro n
+  induction n with
+  | zero => intro l h; have := one_le_size l; omega
+  | succ n ih =>
+    intro l hn
+    have hnorm x (hx : size x ≤ n) : normCmp x x = .eq := by
+      rw [normCmp, ih _ (Nat.le_trans (size_getLevelOffset_le x) hx), Nat.compare_eq_eq.2 rfl]; rfl
+    rw [baseCmp_eq, Nat.compare_eq_eq.2 rfl]
+    show structCmp l l = .eq
+    cases l with simp only [structCmp]
+    | max a b | imax a b =>
+      rw [hnorm a, hnorm b]; rfl
+      all_goals simp only [size] at hn ⊢; omega
+    | _ => exact LawfulBEqCmp.compare_eq_iff_beq.2 (beq_self_eq_true _)
+
+theorem normCmp_refl (l : Level) : normCmp l l = .eq := by
+  rw [normCmp, baseCmp_refl, Nat.compare_eq_eq.2 rfl]; rfl
+
+instance : ReflCmp baseCmp where compare_self := baseCmp_refl _
+instance : ReflCmp normCmp where compare_self := normCmp_refl _
+
+/-- A level is determined by its base and its offset. -/
+private theorem level_ext : ∀ {l₁ l₂ : Level}, l₁.getLevelOffset = l₂.getLevelOffset →
+    l₁.getOffset = l₂.getOffset → l₁ = l₂ := by
+  intro l₁
+  induction l₁ with
+  | succ a ih =>
+    intro l₂
+    cases l₂ with
+    | succ b =>
+      intro h₁ h₂
+      rw [getLevelOffset_succ, getLevelOffset_succ] at h₁
+      rw [getOffset_succ, getOffset_succ] at h₂
+      exact congrArg Level.succ (ih h₁ (by omega))
+    | _ => intro h₁ h₂; rw [getOffset_succ] at h₂; simp [getOffset, getOffsetAux] at h₂
+  | _ =>
+    intro l₂
+    cases l₂ with
+    | succ b => intro h₁ h₂; rw [getOffset_succ] at h₂; simp [getOffset, getOffsetAux] at h₂
+    | _ => intro h₁ h₂; exact h₁
+
+private theorem getLevelOffset_ne_succ : ∀ (l a : Level), l.getLevelOffset ≠ .succ a := by
+  intro l
+  induction l with
+  | succ b ih => exact ih
+  | _ => intro a h; cases h
+
+theorem eq_of_normCmp_eq : ∀ {l₁ l₂ : Level}, normCmp l₁ l₂ = .eq → l₁ = l₂ := by
+  suffices key : ∀ n (l₁ l₂ : Level), size l₁ + size l₂ ≤ n → normCmp l₁ l₂ = .eq → l₁ = l₂ from
+    fun {l₁ l₂} h => key _ l₁ l₂ (Nat.le_refl _) h
+  intro n
+  induction n with
+  | zero => intro l₁ l₂ h; have := one_le_size l₁; have := one_le_size l₂; omega
+  | succ n ih =>
+    intro l₁ l₂ hn h
+    rw [normCmp, baseCmp_eq] at h
+    obtain ⟨h₁, hoff⟩ := Ordering.then_eq_eq.1 h
+    obtain ⟨hc, hs⟩ := Ordering.then_eq_eq.1 h₁
+    refine level_ext ?_ (Nat.compare_eq_eq.1 hoff)
+    have hb₁ := size_getLevelOffset_le l₁
+    have hb₂ := size_getLevelOffset_le l₂
+    have hns₁ := getLevelOffset_ne_succ l₁
+    have hns₂ := getLevelOffset_ne_succ l₂
+    clear h h₁ hoff
+    generalize l₁.getLevelOffset = b₁ at *
+    generalize l₂.getLevelOffset = b₂ at *
+    replace hc := Nat.compare_eq_eq.1 hc
+    cases b₁ <;> cases b₂ <;> try simp only [ctorToNat, Nat.reduceEqDiff] at hc
+    · rfl
+    · exact absurd rfl (hns₁ _)
+    · obtain ⟨e₁, e₂⟩ := Ordering.then_eq_eq.1 hs
+      rw [ih _ _ _ e₁, ih _ _ _ e₂] <;> (simp only [size_max] at hb₁ hb₂ ⊢; omega)
+    · obtain ⟨e₁, e₂⟩ := Ordering.then_eq_eq.1 hs
+      rw [ih _ _ _ e₁, ih _ _ _ e₂] <;> (simp only [size_imax] at hb₁ hb₂ ⊢; omega)
+    · simp only [structCmp] at hs
+      rw [eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 hs)]
+    · rename_i x y
+      have : x.name = y.name := eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 hs)
+      cases x; cases y; simp_all
+
+instance : LawfulEqCmp normCmp where eq_of_compare := eq_of_normCmp_eq
+
+/-! ### `normLt` in terms of `normCmp` -/
+
+private theorem compare_beq_lt (a b : Nat) : (compare a b == Ordering.lt) = decide (a < b) := by
+  apply Bool.eq_iff_iff.2; simp [Nat.compare_eq_lt]
+
+private theorem base_max {a b : Level} : (Level.max a b).getLevelOffset = .max a b := rfl
+private theorem base_imax {a b : Level} : (Level.imax a b).getLevelOffset = .imax a b := rfl
+private theorem off_max {a b : Level} : (Level.max a b).getOffset = 0 := rfl
+private theorem off_imax {a b : Level} : (Level.imax a b).getOffset = 0 := rfl
+
+/-- `normLtAux` accumulates the `succ`s into the offsets and then runs `normCmp`. -/
+private theorem normLtAux_eq : ∀ (l₁ : Level) (k₁ : Nat) (l₂ : Level) (k₂ : Nat),
+    normLtAux l₁ k₁ l₂ k₂ =
+      ((baseCmp l₁.getLevelOffset l₂.getLevelOffset).then
+        (compare (l₁.getOffset + k₁) (l₂.getOffset + k₂)) == .lt) := by
+  intro l₁ k₁ l₂ k₂
+  induction l₁, k₁, l₂, k₂ using normLtAux.induct with
+  | case1 l₁ k₁ l₂ k₂ ih =>
+    rw [normLtAux, ih]
+    simp only [getLevelOffset_succ, getOffset_succ]
+    rw [show l₁.getOffset + 1 + k₁ = l₁.getOffset + (k₁ + 1) by omega]
+  | case2 l₁ k₁ l₂ k₂ hns ih =>
+    rw [normLtAux, ih]
+    simp only [getLevelOffset_succ, getOffset_succ]
+    rw [show l₂.getOffset + 1 + k₂ = l₂.getOffset + (k₂ + 1) by omega]
+    exact hns
+  | case3 a b k₁ c d k₂ hbeq | case6 a b k₁ c d k₂ hbeq =>
+    -- the two levels are syntactically equal: the offsets decide
+    rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff]
+    cases eq_of_beq hbeq
+    show _ ↔ ((baseCmp _ _).then (compare (0 + k₁) (0 + k₂)) == _)
+    rw [baseCmp_refl]
+    simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt]
+  | case4 a b k₁ c d k₂ hbeq hne ih | case7 a b k₁ c d k₂ hbeq hne ih =>
+    -- the heads differ, so the head comparison decides
+    rw [normLtAux, if_neg (by simpa using hbeq), if_pos hne, ih]
+    have hne' : a ≠ c := by simpa using hne
+    have hac : normCmp a c ≠ .eq := fun h => hne' (eq_of_normCmp_eq h)
+    simp only [base_max, base_imax, off_max, off_imax, Nat.add_zero, Nat.zero_add]
+    rw [baseCmp]
+    show ((normCmp a c) == _) = (((normCmp a c).then (normCmp b d)).then (compare k₁ k₂) == _)
+    cases h : normCmp a c <;> simp_all [Ordering.then]
+  | case5 a b k₁ c d k₂ hbeq hne ih | case8 a b k₁ c d k₂ hbeq hne ih =>
+    -- the heads agree, so the tail comparison decides
+    rw [normLtAux, if_neg (by simpa using hbeq), if_neg hne, ih]
+    have hac : a = c := by simpa using hne
+    subst hac
+    have hne' : b ≠ d := by rintro rfl; exact absurd (by simp) hbeq
+    have hbd : normCmp b d ≠ .eq := fun h => hne' (eq_of_normCmp_eq h)
+    simp only [base_max, base_imax, off_max, off_imax, Nat.add_zero, Nat.zero_add]
+    rw [baseCmp]
+    show ((normCmp b d) == _) = (((normCmp a a).then (normCmp b d)).then (compare k₁ k₂) == _)
+    rw [normCmp_refl]
+    cases h : normCmp b d <;> simp_all [Ordering.then]
+  | case9 n₁ k₁ n₂ k₂ hbeq =>
+    rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff]
+    cases eq_of_beq hbeq
+    show _ ↔ ((baseCmp (Level.param n₁) (Level.param n₁)).then (compare (0 + k₁) (0 + k₂)) == _)
+    rw [baseCmp_refl]
+    simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt]
+  | case11 n₁ k₁ n₂ k₂ hbeq =>
+    rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff]
+    cases eq_of_beq hbeq
+    show _ ↔ ((baseCmp (Level.mvar n₁) (Level.mvar n₁)).then (compare (0 + k₁) (0 + k₂)) == _)
+    rw [baseCmp_refl]
+    simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt]
+  | case10 n₁ k₁ n₂ k₂ hbeq =>
+    rw [normLtAux, if_neg hbeq]
+    show _ = ((baseCmp (Level.param n₁) (Level.param n₂)).then
+      (compare (0 + k₁) (0 + k₂)) == _)
+    rw [baseCmp]
+    have : Name.cmp n₁ n₂ ≠ .eq := fun h =>
+      hbeq (LawfulBEqCmp.compare_eq_iff_beq.1 h)
+    cases h : Name.cmp n₁ n₂ <;> simp_all [Name.lt, Ordering.then]
+  | case12 n₁ k₁ n₂ k₂ hbeq =>
+    rw [normLtAux, if_neg hbeq]
+    show _ = ((baseCmp (Level.mvar n₁) (Level.mvar n₂)).then
+      (compare (0 + k₁) (0 + k₂)) == _)
+    rw [baseCmp]
+    have : Name.cmp n₁.name n₂.name ≠ .eq := fun h => hbeq (by
+      have := eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 h)
+      cases n₁; cases n₂; simp_all)
+    cases h : Name.cmp n₁.name n₂.name <;> simp_all [Name.lt, Ordering.then]
+  | case13 l₁ k₁ l₂ k₂ hs₁ hs₂ hmax himax hpar hmvar hbeq
+  | case14 l₁ k₁ l₂ k₂ hs₁ hs₂ hmax himax hpar hmvar hbeq =>
+    -- neither level is a `succ` and their constructors differ, so the tags decide
+    rw [normLtAux, baseCmp_eq]
+    · cases l₁ <;> cases l₂ <;>
+        simp_all [structCmp, ctorToNat, Ordering.then, compare_beq_lt, getLevelOffset, getOffset,
+          getOffsetAux] <;> grind
+    all_goals assumption
+
+theorem normLt_eq (l₁ l₂ : Level) : normLt l₁ l₂ = (normCmp l₁ l₂ == .lt) := by
+  rw [normLt, normLtAux_eq, normCmp, Nat.add_zero, Nat.add_zero]
+
+/-! ### `normLt` is a strict weak order -/
+
+theorem normLt_asymm {a b : Level} (h : normLt a b) : ¬normLt b a := by
+  simp only [normLt_eq, beq_iff_eq] at h ⊢
+  exact OrientedCmp.not_lt_of_lt h
+
+theorem normLt_le_trans {a b c : Level} (h₁ : ¬normLt b a) (h₂ : ¬normLt c b) : ¬normLt c a := by
+  simp only [normLt_eq, beq_iff_eq, ← Ordering.isGE_iff_ne_lt] at h₁ h₂ ⊢
+  exact TransCmp.isGE_trans h₂ h₁
+
+/-- On levels with equal bases, `normLt` compares the offsets. -/
+theorem normLt_same_base {l₁ l₂ : Level} (h : l₁.getLevelOffset = l₂.getLevelOffset) :
+    normLt l₁ l₂ = decide (l₁.getOffset < l₂.getOffset) := by
+  rw [normLt_eq, normCmp, h, baseCmp_refl]
+  simp only [Ordering.then, compare_beq_lt]
+
+end Lean.Level
diff --git a/Lean4Lean/Verify/QSort.lean b/Lean4Lean/Verify/QSort.lean
new file mode 100644
index 00000000..f5fd0cd8
--- /dev/null
+++ b/Lean4Lean/Verify/QSort.lean
@@ -0,0 +1,392 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kim Morrison
+-/
+module
+public import Init.Data.Array.Basic
+import all Init.Data.Array.QSort.Basic
+
+/-!
+# Verification of `Array.qsort`
+
+Adapted from the verification in leanprover/lean4#14658
+(tests/elab/grind_qsort.lean on the `qsort_verification` branch).
+
+This file contains a verification of the `Array.qsort` function,
+using the `grind` tactic.
+
+The theorems are:
+* `size_qsort : (qsort as lt lo hi).size = as.size`
+* `qsort_perm : qsort as lt lo hi ~ as`
+
+And when `lt` is antisymmetric and `¬ lt a b` is transitive, we have:
+* `qsort_sorted' : lo ≤ i < j ≤ hi → ¬ lt (as.qsort lt lo hi)[j] (as.qsort lt lo hi)[i]`
+* `qsort_sorted : i < j → ¬ lt (as.qsort lt)[j] (as.qsort lt)[i]`
+
+(There is not currently a public theorem that `(qsort as lt lo hi)[i] = as[i]` when `i < lo` or `hi < i`.)
+
+-/
+namespace Array
+
+open List Vector
+
+-- These attributes still need to be moved to the standard library.
+
+-- set_option trace.grind.ematch.pattern true in
+-- attribute [grind] Vector.getElem?_eq_getElem -- This one requires some consideration! -- Probably not need, see Vector.Perm.extract' below.
+
+-- Hmm, we don't seem to have the Array analogues of these!
+attribute [grind =] Vector.toArray_perm_iff
+attribute [grind =] Vector.perm_toArray_iff
+
+attribute [grind .] Vector.swap_perm
+
+attribute [grind .] List.Perm.refl
+attribute [grind .] Array.Perm.refl
+attribute [grind .] Vector.Perm.refl
+
+-- attribute [grind] Array.Perm.extract
+-- attribute [grind] Vector.Perm.extract
+
+-- These are just the patterns resulting from `grind`, but the behaviour should be explained!
+grind_pattern List.Perm.trans => l₁ ~ l₂, l₁ ~ l₃
+grind_pattern Array.Perm.trans => xs ~ ys, xs ~ zs
+grind_pattern Vector.Perm.trans => xs ~ ys, xs ~ zs
+
+/-- Variant of `List.Perm.take` specifying the permutation is constant after `i` elementwise. -/
+theorem _root_.List.Perm.take_of_getElem {l₁ l₂ : List α} (h : l₁ ~ l₂) {i : Nat}
+    (w : ∀ j, i ≤ j → (_ : j < l₁.length) → l₁[j] = l₂[j]'(by have := h.length_eq; omega)) :
+    l₁.take i ~ l₂.take i := by
+  apply h.take_of_getElem?
+  intro j hij
+  by_cases h_length₁ : j < l₁.length
+  <;> have h_length₂ := h.length_eq ▸ h_length₁
+  <;> grind
+
+/-- Variant of `List.Perm.drop` specifying the permutation is constant before `i` elementwise. -/
+theorem _root_.List.Perm.drop_of_getElem {l₁ l₂ : List α} (h : l₁ ~ l₂) {i : Nat}
+    (w : ∀ j, j < i → (_ : j < l₁.length) → l₁[j] = l₂[j]'(by have := h.length_eq; omega)) :
+    l₁.drop i ~ l₂.drop i := by
+  apply h.drop_of_getElem?
+  intro j hij
+  by_cases h_length₁ : j < l₁.length
+  <;> have h_length₂ := h.length_eq ▸ h_length₁
+  <;> grind
+
+private theorem getElem_mk {l : List α} {i : Nat} (h : i < l.length) :
+    (Array.mk l)[i]'(by simpa using h) = l[i] := by
+  rw [← Array.getElem_toList]
+
+theorem _root_.Array.Perm.extract' {xs ys : Array α} (h : xs ~ ys) {lo hi : Nat}
+    (wlo : ∀ i, i < lo → (_ : i < xs.size) → xs[i] = ys[i]'(by have := h.size_eq; omega))
+    (whi : ∀ i, hi ≤ i → (_ : i < xs.size) → xs[i] = ys[i]'(by have := h.size_eq; omega)) :
+    xs.extract lo hi ~ ys.extract lo hi := by
+  rcases xs with ⟨xs⟩
+  rcases ys with ⟨ys⟩
+  simp_all only [perm_iff_toList_perm, List.extract_toArray]
+  apply List.Perm.take_of_getElem
+    (w := fun i h₁ h₂ => by
+      rw [List.getElem_drop, List.getElem_drop, ← getElem_mk, ← getElem_mk]
+      exact whi (lo + i) (by omega) (by grind))
+  apply List.Perm.drop_of_getElem
+    (w := fun i h₁ h₂ => by
+      rw [← getElem_mk, ← getElem_mk]
+      exact wlo i h₁ (by grind))
+  simpa using List.perm_iff_toArray_perm.mpr h
+
+theorem _root_.Vector.Perm.extract' {xs ys : Vector α n} (h : xs ~ ys) {lo hi : Nat}
+    (wlo : ∀ i, i < lo → (_ : i < n) → xs[i] = ys[i]) (whi : ∀ i, hi ≤ i → (_ : i < n) → xs[i] = ys[i]) :
+    xs.extract lo hi ~ ys.extract lo hi := by
+  rcases xs with ⟨xs, rfl⟩
+  rcases ys with ⟨ys, h⟩
+  exact ⟨Array.Perm.extract' h.toArray (by simpa using wlo) (by simpa using whi)⟩
+
+attribute [grind .] Array.Perm.extract'
+attribute [grind .] Vector.Perm.extract'
+
+variable (lt : α → α → Bool) (lo hi : Nat)
+
+@[simp, grind =] public theorem size_qsort (as : Array α) :
+    (qsort as lt lo hi).size = as.size := by
+  grind [qsort]
+
+private theorem qpartition_loop_perm (as : Vector α n)
+    (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) :
+    (qpartition.loop lt lo hi hhi pivot as i k).2 ~ as := by
+  fun_induction qpartition.loop with grind
+
+@[local grind .]
+private theorem qpartition_perm
+    (as : Vector α n) (w : lo ≤ hi) (hlo : lo < n) (hhi : hi < n) :
+    (qpartition as lt lo hi).2 ~ as := by
+  unfold qpartition
+  refine Vector.Perm.trans (qpartition_loop_perm ..) ?_
+  repeat' first
+  | split
+  | grind
+  | refine Vector.Perm.trans (Vector.swap_perm ..) ?_
+
+private theorem qsort_sort_perm
+    (as : Vector α n) (w : lo ≤ hi) (hlo : lo < n) (hhi : hi < n) :
+    qsort.sort lt as lo hi w hlo hhi ~ as := by
+  fun_induction qsort.sort with grind
+
+grind_pattern qsort_sort_perm => qsort.sort lt as lo hi w hlo hhi
+
+public theorem qsort_perm (as : Array α) : qsort as lt lo hi ~ as := by
+  grind [qsort]
+
+private theorem getElem_qpartition_loop_snd_of_lt_lo
+    (hhi : hi < n) (as : Vector α n) (i k : Nat) (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) (w' : lo ≤ hi)
+    (l : Nat) (h : l < lo) : (qpartition.loop lt lo hi hhi pivot as i k).2[l] = as[l] := by
+  fun_induction qpartition.loop <;> grind
+
+private theorem getElem_qpartition_snd_of_lt_lo (as : Vector α n)
+    (hhi : hi < n) (w : lo ≤ hi)
+    (k : Nat) (h : k < lo) : (qpartition as lt lo hi).2[k] = as[k] := by
+  grind [qpartition, getElem_qpartition_loop_snd_of_lt_lo]
+
+@[local grind =] private theorem getElem_qsort_sort_of_lt_lo
+    (as : Vector α n)
+    (hlo : lo < n) (hhi : hi < n) (w : lo ≤ hi)
+    (i : Nat) (h : i < lo) : (qsort.sort lt as lo hi)[i] = as[i] := by
+  fun_induction qsort.sort with grind [getElem_qpartition_snd_of_lt_lo]
+
+private theorem getElem_qpartition_loop_snd_of_hi_lt
+    (hhi : hi < n) (as : Vector α n) (i k)
+    (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) (z : i ≤ hi)
+    (l : Nat) (h : hi < l) (h' : l < n) : (qpartition.loop lt lo hi hhi pivot as i k).2[l] = as[l] := by
+  fun_induction qpartition.loop <;> grind
+
+private theorem getElem_qpartition_snd_of_hi_lt (as : Vector α n)
+    (hhi : hi < n) (w : lo ≤ hi)
+    (k : Nat) (h : hi < k) (h' : k < n) : (qpartition as lt lo hi).2[k] = as[k] := by
+  grind [qpartition, getElem_qpartition_loop_snd_of_hi_lt]
+
+@[local grind =] private theorem getElem_qsort_sort_of_hi_lt
+    (as : Vector α n) (w : lo ≤ hi)
+    (hlo : lo < n) (hhi : hi < n) (w : lo ≤ hi)
+    (i : Nat) (h : hi < i) (h' : i < n) : (qsort.sort lt as lo hi)[i] = as[i] := by
+  fun_induction qsort.sort with grind [getElem_qpartition_snd_of_hi_lt]
+
+private theorem extract_qsort_sort_perm (as : Vector α n) (lt : α → α → Bool)
+    (hlo := by grind) (hhi := by grind) (w : lo ≤ hi := by grind) :
+    ((qsort.sort lt as lo hi).extract lo (hi + 1)) ~ (as.extract lo (hi + 1)) := by
+  grind
+
+private theorem getElem_qsort_sort_mem
+    (as : Vector α n) (hhi : hi < n) (i : Nat) (h : i < n) (_ : lo ≤ i) (_ : i ≤ hi) :
+    (qsort.sort lt as lo hi)[i] ∈ as.extract lo (hi + 1) := by
+  rw [← (extract_qsort_sort_perm lo hi as lt).mem_iff, Vector.mem_extract_iff_getElem]
+  exact ⟨i - lo, by grind⟩
+
+private theorem qpartition_loop_spec₁
+    (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (khi : k ≤ hi)
+    (as : Vector α n) (hpivot : pivot = as[hi])
+    (q : ∀ l, (hk₁ : lo ≤ l) → (hk₂ : l < i) → lt as[l] as[hi]) (mid as')
+    (w_mid : mid = (qpartition.loop lt lo hi hhi pivot as i k).fst.1) (hmid : mid < n)
+    (w_as : as' = (qpartition.loop lt lo hi hhi pivot as i k).2) :
+    ∀ l, (h₁ : lo ≤ l) → (h₂ : l < mid) → lt as'[l] as'[mid] := by
+  fun_induction qpartition.loop with unfold qpartition.loop at w_mid w_as
+  | case1
+  | case2 => apply_assumption <;> grind
+  | case3 => grind
+
+private theorem qpartition_loop_spec₂
+    (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (khi : k ≤ hi)
+    (as : Vector α n) (hpivot : pivot = as[hi])
+    (q : ∀ l, (hk₁ : i ≤ l) → (hk₂ : l < k) → !lt as[l] as[hi]) (mid as')
+    (w_mid : mid = (qpartition.loop lt lo hi hhi pivot as i k).fst.1) (hmid : mid < n)
+    (w_as : as' = (qpartition.loop lt lo hi hhi pivot as i k).2) :
+    ∀ l, (h₁ : mid < l) → (h₂ : l ≤ hi) → lt as'[l] as'[mid] = false := by
+  fun_induction qpartition.loop with grind
+
+/--
+All elements in the active range before the pivot, are less than the pivot.
+-/
+private theorem qpartition_spec₁
+    (hhi : hi < n) (w : lo ≤ hi)
+    (as : Vector α n) (mid as')
+    (w_mid : mid = (qpartition as lt lo hi).fst.1) (hmid : mid < n)
+    (w_as : as' = (qpartition as lt lo hi).2) :
+    ∀ i, (h₁ : lo ≤ i) → (h₂ : i < mid) → lt as'[i] as'[mid] := by
+  grind [qpartition, qpartition_loop_spec₁]
+
+/--
+All elements in the active range after the pivot, are greater than or equal to the pivot.
+-/
+private theorem qpartition_spec₂
+    (hhi : hi < n) (w : lo ≤ hi)
+    (as : Vector α n) (mid as')
+    (w_mid : mid = (qpartition as lt lo hi).fst.1) (hmid : mid < n)
+    (w_as : as' = (qpartition as lt lo hi).2) :
+    ∀ i, (h₁ : mid < i) → (h₂ : i ≤ hi) → lt as'[i] as'[mid] = false := by
+  grind [qpartition, qpartition_loop_spec₂]
+
+/-!
+We now need to deal with a corner case:
+we need to show that `qpartition` only returns a value `≥ hi` when `hi ≤ lo`
+(and hence the slice of the array between `lo` and `hi` (inclusive) is trivially already sorted).
+
+We prove two preliminary lemmas about `qpartition.loop`.
+-/
+
+/-- If we already have `i < k`, then we're sure to return something less than `hi`. -/
+private theorem qpartition_loop_lt_hi₁
+    (ilo : lo ≤ i) (ik : i < k) (w : k ≤ hi) (z : k ≤ hi) (ik' : i ≤ k) :
+    (qpartition.loop lt lo hi hhi pivot as i k).1.val < hi := by
+  fun_induction qpartition.loop with grind
+
+/--
+Otherwise, if there is some position `k' ≥ k` which is greater than or equal to the pivot,
+then when we reach that we'll be sure `i < k`, and hence the previous lemma will apply,
+and so we're sure to return something less than `hi`.
+ -/
+private theorem qpartition_loop_lt_hi₂
+    {as : Vector α n} (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (z : k ≤ hi)
+    (q : ∃ (k' : Nat) (hj' : k' < n), k' ≥ k ∧ k' < hi ∧ ¬ lt as[k'] pivot) :
+    (qpartition.loop lt lo hi hhi pivot as i k).1.val < hi := by
+  fun_induction qpartition.loop with
+  | case1 =>
+    -- It would be nice if a more aggressive mode in `grind` would do this.
+    apply_assumption <;> grind
+  | case2 => grind [qpartition_loop_lt_hi₁]
+  | case3 => grind
+
+/-- The only way `qpartition` returns a pivot position `≥ hi` is if `hi ≤ lo`. -/
+private theorem qpartition_fst_lt_hi (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (as : Vector α n) (hhi : hi < n) (w : lo < hi) : (qpartition as lt lo hi).fst.1 < hi := by
+  apply qpartition_loop_lt_hi₂ lt lo hi
+  · grind
+  · exact ⟨(lo + hi)/2, by grind⟩
+
+private theorem qsort_sort_spec
+    (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a)
+    (as : Vector α n) (lo hi : Nat) (hhi : hi < n) (w : lo ≤ hi)
+    (as' : Vector α n) (w_as : as' = qsort.sort lt as lo hi) :
+    ∀ i, (h₁ : lo ≤ i) → (h₂ : i < hi) → ¬ lt (as')[i + 1] as'[i] := by
+  unfold qsort.sort at w_as
+  split at w_as <;> rename_i w₁
+  · -- The interesting case, where `lo < hi`.
+    intro i h₁ h₂
+    -- Decompose `qpartition as lt lo hi` into `mid` (the pivot) and `as'` (the partitioned array).
+    split at w_as <;> rename_i mid hmid as' w₂
+    split at w_as <;> rename_i w₃
+    · -- If the pivot was at least `hi`, then we get a contradiction from `lo < hi`.
+      simp only [Prod.ext_iff, Subtype.ext_iff] at w₂
+      obtain ⟨rfl, rfl⟩ := w₂
+      have := qpartition_fst_lt_hi lt lo hi lt_asymm as hhi w₁
+      grind
+    · -- Now we know `lo ≤ mid < hi`.
+      subst w_as
+      if p₁ : i < mid then
+        -- If `i < mid`, then the second stage of sorting is only
+        -- moving elements above where we're looking.
+        rw [getElem_qsort_sort_of_lt_lo (i := i)]
+        rw [getElem_qsort_sort_of_lt_lo (i := i + 1)]
+        -- And so we can apply the theorem recursively replacing `hi` with `mid`.
+        apply qsort_sort_spec lt_asymm le_trans as' lo mid
+        -- The remaining arithmetic side conditions are easily resolved.
+        all_goals grind
+      else
+        replace p₁ : mid ≤ i := by grind
+        -- If `mid ≤ i`, we need to consider two cases.
+        if p₃ : mid = i then
+          -- The tricky case, where `mid = i`.
+          subst i
+          -- On the right hand side, the index is below the range where the second stage of sorting is happening,
+          -- so we can drop that sort.
+          rw [getElem_qsort_sort_of_lt_lo (i := mid)]
+          -- The `mid` element of `qsort.sort lt as' lo mid ⋯`
+          -- is *some* element `lo + k` of `as'` in the range `lo ≤ lo + k ≤ mid`.
+          have z := getElem_qsort_sort_mem lt lo mid as' ?_ mid ?_ ?_ ?_
+          rw [Vector.mem_extract_iff_getElem] at z
+          obtain ⟨k, hk, z⟩ := z
+          rw [← z]
+          clear z
+          -- Similarly, the `mid + 1` element on the left hand side
+          -- is some element `mid + 1 + k'` of `qsort.sort lt as' lo mid ⋯`
+          -- in the range `mid + 1 ≤ mid + 1 + k' ≤ hi`
+          have z := getElem_qsort_sort_mem lt (mid + 1) hi
+            (qsort.sort lt as' lo mid ?_ ?_) ?_ (mid + 1) ?_ ?_ ?_
+          rw [Vector.mem_extract_iff_getElem] at z
+          obtain ⟨k', hk', z⟩ := z
+          rw [← z]
+          clear z
+          -- And then the first stage sort on the left hand side can't have any effect,
+          -- as it only moves elements between `lo` and `mid` inclusive.
+          rw [getElem_qsort_sort_of_hi_lt]
+          · by_cases p : lo + k = mid
+            · -- Now if `lo + k = mid`,
+              -- the element `as'[mid + 1 + k']` is in the top part of the partitioned array,
+              -- and `as[lo + k]` is the pivot, so we get the inequality from the specification of `qpartition`.
+              grind [qpartition_spec₂]
+            · -- Otherwise, we use transitivity:
+              -- `as[lo + k']` is in the bottom part, so is strictly less than the pivot,
+              -- while `as'[mid + 1 + k']` is in the top, so greater than or equal to the pivot.
+              apply le_trans (b := as'[mid])
+              · grind [qpartition_spec₁]
+              · grind [qpartition_spec₂]
+          -- Various arithmetic side conditions remain from the rewriting,
+          -- but are now all easy to resolve.
+          all_goals grind
+        else
+          -- If `i < mid`, we can apply the theorem recursively replacing
+          -- `as` with `qsort.sort lt as' lo mid ⋯` and `lo` with `mid + 1`.
+          apply qsort_sort_spec lt_asymm le_trans _ _ _ (w_as := rfl) <;> grind
+  · -- Just an arithmetical contradiction.
+    grind
+
+/--
+The slice of `as.qsort lt lo hi` from `lo` to `hi` (inclusive) is sorted.
+
+This variant states that adjacent elements are non-decreasing.
+See `qsort_sorted'` for a variant about arbitrary pairs of indices.
+-/
+public theorem qsort_sorted₁' (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a)
+    (as : Array α) (lo hi : Nat) (i) (h₁ : lo ≤ i) (h₂ : i < hi) (h₃ : i + 1 < as.size) :
+      ¬ lt ((as.qsort lt lo hi)[i + 1]'(by grind)) ((as.qsort lt lo hi)[i]'(by grind)) := by
+  unfold qsort
+  split <;> rename_i w
+  · grind
+  · apply qsort_sort_spec lt lt_asymm le_trans (w_as := rfl) <;> grind
+
+/--
+`Array.qsort` returns a sorted array, i.e. adjacent elements are non-decreasing.
+
+See `qsort_sorted` for a variant about arbitrary pairs of indices.
+-/
+public theorem qsort_sorted₁ (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) (as : Array α)
+    (i) (h : i + 1 < (qsort as lt).size) :
+    ¬ lt (as.qsort lt)[i + 1] (as.qsort lt)[i] := by
+  have := qsort_sorted₁' lt lt_asymm le_trans
+  grind
+
+/-- The slice of `as.qsort lt lo hi` from `lo` to `hi` (inclusive) is sorted. -/
+public theorem qsort_sorted' (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a)
+    (as : Array α) (lo hi : Nat) (i j) (h₁ : lo ≤ i) (h₂ : i < j) (h₃ : j ≤ hi) (h₄ : j < as.size) :
+      ¬ lt ((as.qsort lt lo hi)[j]'(by grind)) ((as.qsort lt lo hi)[i]'(by grind)) := by
+  induction j with
+  | zero => grind
+  | succ j ih =>
+    if p : i = j then
+      subst p
+      apply qsort_sorted₁' <;> grind
+    else
+      apply le_trans (b := (as.qsort lt lo hi)[j]'(by grind))
+      · grind
+      · apply qsort_sorted₁' <;> grind
+
+public theorem qsort_sorted (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a)
+    (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) (as : Array α) :
+    ∀ i j, (h₁ : i < j) → (h₂ : j < (qsort as lt).size) →
+      ¬ lt (as.qsort lt)[j] (as.qsort lt)[i] := by
+  have := qsort_sorted' lt lt_asymm le_trans
+  grind
+
+end Array
diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean
index 858cb755..ce15a2ac 100644
--- a/Lean4Lean/Verify/TypeChecker.lean
+++ b/Lean4Lean/Verify/TypeChecker.lean
@@ -16,7 +16,37 @@ structure VEnvs.WF (env : Environment) (ves : VEnvs) where
   safePrimitives : env.find? n = some ci →
     Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = []
   mono : safety ≤ safety' → ves.venv safety' ≤ ves.venv safety
+  projectionReady : ProjectionReady env (ves.venv safety)
+  structureEtaReady : StructureEtaReady env (ves.venv safety)
+
+/-- Assemble a `VEnvs` from a pointwise existential. `DefinitionSafety` has three elements, so
+this is a finite case split rather than an appeal to choice -- the name records what it replaces. -/
+theorem VEnvs.axiom_of_choice {P : DefinitionSafety → VEnv → Prop} (H : ∀ sf, ∃ x, P sf x) :
+    ∃ x : VEnvs, ∀ sf, P sf (x.venv sf) := by
+  have ⟨x1, _⟩ := H .safe; have ⟨x2, _⟩ := H .partial; have ⟨x3, _⟩ := H .unsafe
+  exact ⟨⟨fun | .safe => x1 | .partial => x2 | .unsafe => x3⟩, by rintro ⟨⟩ <;> assumption⟩
+
+/-- A model of `env` at a *single* safety level, which is all the type checker consumes.
+
+`VEnvs.WF` bundles one of these at every level, but not every environment the checker runs
+against admits that: while a `partial` mutual block is being checked its members are present
+as axioms tagged `safe` (an `AxiomVal` cannot be tagged `partial`), and their types were only
+checked at `partial`, so there is no `safe`-level model of that environment. -/
+structure VEnvAt (env : Environment) (safety : DefinitionSafety) (venv : VEnv) : Prop where
+  tr : TrEnv safety env venv
+  hasPrimitives : VEnv.HasPrimitives venv
+  safePrimitives : env.find? n = some ci →
+    Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = []
+  projectionReady : ProjectionReady env venv
+  structureEtaReady : StructureEtaReady env venv
 
+theorem VEnvs.WF.toVEnvAt {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (safety : DefinitionSafety) : VEnvAt env safety (ves.venv safety) where
+  tr := wf.tr
+  hasPrimitives := wf.hasPrimitives
+  safePrimitives := wf.safePrimitives
+  projectionReady := wf.projectionReady
+  structureEtaReady := wf.structureEtaReady
 
 namespace TypeChecker
 open Inner
@@ -37,21 +67,26 @@ theorem Methods.withFuel.WF : ∀ {n}, (withFuel n).WF
 theorem RecM.WF.run {x : RecM α} (H : x.WF c s Q) : (RecM.run x).WF c s Q :=
   H _ Methods.withFuel.WF
 
-def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env)
-    (safety : DefinitionSafety := .safe) (lparams : List Name := [])
+def VContext.mk1 {env : Environment} {safety : DefinitionSafety} {venv : VEnv}
+    (wf : VEnvAt env safety venv) (lparams : List Name := [])
     (fuel : FuelConfig := {}) : VContext where
-  env; safety; lparams; fuel
-  venv := ves.venv safety
+  env; safety; lparams; fuel; venv
   hasPrimitives := wf.hasPrimitives
   safePrimitives := wf.safePrimitives
   trenv := wf.tr
+  projectionReady := wf.projectionReady
+  structureEtaReady := wf.structureEtaReady
   mlctx := .nil
   mlctx_wf := trivial
   lctx_eq := rfl
 
-theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env}
-    {safety : DefinitionSafety} {lparams : List Name} {fuel : FuelConfig} :
-    VState.WF (.mk' wf safety lparams fuel) {} where
+def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    (safety : DefinitionSafety := .safe) (lparams : List Name := [])
+    (fuel : FuelConfig := {}) : VContext := .mk1 (wf.toVEnvAt safety) lparams fuel
+
+theorem VState.WF.empty1 {env : Environment} {safety : DefinitionSafety} {venv : VEnv}
+    {wf : VEnvAt env safety venv} {lparams : List Name} {fuel : FuelConfig} :
+    VState.WF (.mk1 wf lparams fuel) {} where
   trctx := .nil
   ngen_wf := nofun
   ectx := ⟨[], .refl, trivial, .refl, .empty, nofun⟩
@@ -61,15 +96,99 @@ theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env}
   whnf_wf := .empty
   unfold_wf _ := by simp
 
-theorem M.WF.run {env : Environment} {ves : VEnvs} (wf : ves.WF env)
-    {x : M α} {Q} (H : x.WF (.mk' wf safety lparams fuel) {} fun a _ => Q a) :
+theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env}
+    {safety : DefinitionSafety} {lparams : List Name} {fuel : FuelConfig} :
+    VState.WF (.mk' wf safety lparams fuel) {} := by
+  unfold VContext.mk'; exact .empty1
+
+theorem M.WF.run1 {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv)
+    {x : M α} {Q} (H : x.WF (.mk1 wf lparams fuel) {} fun a _ => Q a) :
     (M.run env safety {} lparams fuel x).WF Q := by
   intro a eq
   simp [M.run, Functor.map, Except.map] at eq
   split at eq <;> cases eq; rename_i eq
-  let ⟨_, _, _, _, H⟩ := H .empty _ _ eq
+  let ⟨_, _, _, _, H⟩ := H .empty1 _ _ eq
   exact H
 
+theorem M.WF.run {env : Environment} {ves : VEnvs} (wf : ves.WF env)
+    {x : M α} {Q} (H : x.WF (.mk' wf safety lparams fuel) {} fun a _ => Q a) :
+    (M.run env safety {} lparams fuel x).WF Q := by
+  unfold VContext.mk' at H; exact M.WF.run1 _ H
+
+/-- Loop invariant rule for `for x in xs do ...`. `Inv` is indexed by the list still to be
+processed, so the conclusion `Inv []` records that every element was handled. The body must
+`yield`; a loop that can `break` is out of scope (none of the kernel's loops do). -/
+theorem M.WF.forIn {c : VContext} {f : α → β → M (ForInStep β)}
+    {Inv : List α → β → VState → Prop}
+    (H : ∀ v vs b s, Inv (v :: vs) b s →
+      (f v b).WF c s fun r s' => ∃ b', r = .yield b' ∧ Inv vs b' s') :
+    ∀ {vs : List α} {b : β} {s : VState}, Inv vs b s →
+      (forIn vs b f).WF c s fun b' s' => Inv [] b' s'
+  | [], _, _, h => .pure h
+  | v :: vs, b, s, h => by
+    rw [List.forIn_cons]
+    refine (H v vs b s h).bind fun r s' _ hr => ?_
+    obtain ⟨b', rfl, hinv⟩ := hr
+    exact M.WF.forIn H hinv
+
+theorem M.WF.bindThrow {c : VContext} {s : VState} {x : M α} {f : α → M β} {Q}
+    (h : x.WF c s fun _ _ => False) : (x >>= f).WF c s Q :=
+  h.bind fun _ _ _ hf => hf.elim
+
+/-- Loop rule for `addMutual`'s header loop, whose accumulator is the set of names seen so
+far: each iteration rejects a name already in the set, so the whole block is duplicate-free. -/
+theorem M.WF.forInFresh {c : VContext} {Q : Lean.DefinitionVal → β → Prop}
+    {f : Lean.DefinitionVal → NameSet → M (ForInStep NameSet)}
+    (H : ∀ v found s, (f v found).WF c s fun r _ =>
+      found.contains v.name = false ∧ (∃ b, Q v b) ∧ r = .yield (found.insert v.name)) :
+    ∀ {vs : List Lean.DefinitionVal} {found : NameSet} {s : VState},
+      (ForIn.forIn vs found f).WF c s fun _ _ =>
+        (∃ bs, List.Forall₂ Q vs bs) ∧ (vs.map (·.name)).Nodup ∧
+          ∀ v ∈ vs, found.contains v.name = false
+  | [], _, _ => .pure ⟨⟨[], .nil⟩, by simp, by simp⟩
+  | v :: vs, found, s => by
+    rw [List.forIn_cons]
+    refine (H v found s).bind fun r s' _ h => ?_
+    obtain ⟨hfresh, ⟨b, hb⟩, rfl⟩ := h
+    refine (M.WF.forInFresh H (vs := vs) (found := found.insert v.name)).mono
+      fun _ _ _ h => ?_
+    obtain ⟨⟨bs, hbs⟩, hnd, hmem⟩ := h
+    refine ⟨⟨b :: bs, .cons hb hbs⟩, ?_, ?_⟩
+    · rw [List.map_cons, List.nodup_cons]
+      refine ⟨fun hm => ?_, hnd⟩
+      obtain ⟨w, hw, hwn⟩ := List.mem_map.1 hm
+      have := hmem w hw
+      rw [NameSet.contains_insert, hwn] at this
+      simp at this
+    · intro w hw
+      cases hw with
+      | head => exact hfresh
+      | tail _ hw =>
+        have := hmem w hw
+        rw [NameSet.contains_insert] at this
+        exact (by simpa using this : _ ∧ _).2
+
+/-- Loop rule for a loop whose elements are already related to a list `cis`, so each iteration
+may use the datum paired with the element it processes; each refines its `ci` to a `ci'`
+related by `R`. -/
+theorem M.WF.forInForall₂ {c : VContext} {f : α → Unit → M (ForInStep Unit)}
+    {P : α → β → Prop} {R : β → β → Prop} {Q : α → β → Prop}
+    (H : ∀ v ci s, P v ci → (f v ()).WF c s fun r _ =>
+      (∃ ci', R ci ci' ∧ Q v ci') ∧ r = .yield ()) :
+    ∀ {vs : List α} {cis : List β} {s : VState}, List.Forall₂ P vs cis →
+      (ForIn.forIn vs () f).WF c s fun _ _ =>
+        ∃ cis', List.Forall₂ R cis cis' ∧ List.Forall₂ Q vs cis' := by
+  intro vs cis s h
+  induction h generalizing s with
+  | nil => exact .pure ⟨[], .nil, .nil⟩
+  | @cons v ci vs cis hd tl ih =>
+    rw [List.forIn_cons]
+    refine (H v ci s hd).bind fun r s' _ h => ?_
+    obtain ⟨⟨ci', hR, hQ⟩, rfl⟩ := h
+    refine (ih (s := s')).mono fun _ _ _ h => ?_
+    obtain ⟨cis', h1, h2⟩ := h
+    exact ⟨ci' :: cis', .cons hR h1, .cons hQ h2⟩
+
 nonrec theorem whnf.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
     M.WF c s (whnf e) fun e₁ _ => c.TrExpr e₁ e' :=
   (whnf.WF he).run.mono fun _ _ _ h => h.2
diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean
index 6252d896..877b073f 100644
--- a/Lean4Lean/Verify/TypeChecker/Basic.lean
+++ b/Lean4Lean/Verify/TypeChecker/Basic.lean
@@ -101,6 +101,168 @@ theorem WF.weak' (wf : WF env Us Δ m) : WF env Us Δ' m where
 
 end EquivManager
 
+/-- Exact alignment between one host structure record and the registered
+Theory artifact used to interpret primitive projections.  The positional
+metadata is retained explicitly because ordinary constant translation checks
+types but does not identify the kernel's parameter/constructor roles. -/
+structure ProjectionArtifact (env : Environment) (name : Name)
+    (info : InductiveVal) (venv : VEnv) where
+  view : VStructureView
+  name_eq : view.name = name
+  viewWF : view.WF venv
+  constructorInfo : ConstructorVal
+  constructor_find : env.find? view.constructorName =
+    some (.ctorInfo constructorInfo)
+  constructor_numParams_eq : constructorInfo.numParams = view.nparams
+  constructor_numFields_eq : constructorInfo.numFields = view.fields.length
+  levelParams_length : info.levelParams.length = view.uvars
+  numParams_eq : info.numParams = view.nparams
+  numIndices_eq : info.numIndices = 0
+  ctors_eq : info.ctors = [view.constructorName]
+  rawResult_sort : ∃ resultLevel,
+    view.generation.block.rawResult = .sort resultLevel
+  programsWF : view.ProgramsWF venv
+
+/-- Host/Theory coherence needed by primitive projections.
+
+Inference obtains one complete registered artifact from ready family
+metadata. Reduction additionally relies on the positional host fact that a
+constructor's cached `numParams` agrees with the registered Theory view;
+ordinary constant translation checks the constructor type but does not
+identify which leading binders the host metadata classifies as parameters. -/
+structure ProjectionReady (env : Environment) (venv : VEnv) : Prop where
+  infer : ∀ name info, env.find? name = some (.inductInfo info) →
+    env.isProjectionReadyStructure name = true →
+    Nonempty (ProjectionArtifact env name info venv)
+  constructorNumParams : ∀ (view : VStructureView) (info : ConstructorVal),
+    view.WF venv →
+    env.find? view.constructorName = some (.ctorInfo info) →
+    info.numParams = view.nparams
+
+/-- Exact host/Theory alignment for one constructor/family pair accepted by
+the runtime structure-eta heuristics.  The underlying projection artifact
+supplies the registered Theory view and its typed projector programs; the two
+equalities identify that artifact with the precise host constructor lookup
+which triggered the heuristic. -/
+structure StructureEtaArtifact (env : Environment) (familyName : Name)
+    (familyInfo : InductiveVal) (constructorName : Name)
+    (constructorInfo : ConstructorVal) (venv : VEnv) where
+  projection : ProjectionArtifact env familyName familyInfo venv
+  constructor_name_eq : projection.view.constructorName = constructorName
+  constructor_info_eq : projection.constructorInfo = constructorInfo
+  /-- The ordered registry proof fixes the exact descriptor generated from
+  the checked view.  It contains no equality oracle: the associated
+  subject-reduction package is recovered by `Ordered.structEtaWF`. -/
+  etaOrdered : venv.Ordered
+  etaRegistered : venv.structEtas
+    (projection.viewWF.toStructEta etaOrdered)
+
+/-- Host-metadata coherence required whenever the executable checker accepts
+a family/constructor pair as a nonrecursive structure.  This deliberately
+contains no Theory equality: `VEnv.HasStructureEta` is the separate semantic
+capability consumed by the verification theorem. -/
+structure StructureEtaReady (env : Environment) (venv : VEnv) : Prop where
+  resolve : ∀ familyName familyInfo constructorName constructorInfo,
+    env.find? familyName = some (.inductInfo familyInfo) →
+    env.find? constructorName = some (.ctorInfo constructorInfo) →
+    env.isNonRecStructure familyName = true →
+    Nonempty (StructureEtaArtifact env familyName familyInfo
+      constructorName constructorInfo venv)
+
+/-- Resolve the family artifact named by a constructor lookup after the
+runtime nonrecursive-structure test has succeeded. -/
+theorem StructureEtaReady.resolveConstructor
+    (self : StructureEtaReady env venv)
+    (hctor : env.find? constructorName = some (.ctorInfo constructorInfo))
+    (hnonrec : env.isNonRecStructure constructorInfo.induct = true) :
+    ∃ familyInfo,
+      env.find? constructorInfo.induct = some (.inductInfo familyInfo) ∧
+      Nonempty (StructureEtaArtifact env constructorInfo.induct familyInfo
+        constructorName constructorInfo venv) := by
+  have hshape := hnonrec
+  unfold Kernel.Environment.isNonRecStructure at hshape
+  generalize hfamily : env.find? constructorInfo.induct = found at hshape
+  cases found with
+  | none => simp at hshape
+  | some info => cases info with
+    | inductInfo familyInfo =>
+      exact ⟨familyInfo, rfl,
+        self.resolve _ _ _ _ hfamily hctor hnonrec⟩
+    | axiomInfo _ => simp at hshape
+    | defnInfo _ => simp at hshape
+    | thmInfo _ => simp at hshape
+    | opaqueInfo _ => simp at hshape
+    | quotInfo _ => simp at hshape
+    | ctorInfo _ => simp at hshape
+    | recInfo _ => simp at hshape
+
+/-- Consume the exact registered descriptor retained by a resolved host
+structure artifact.  Reconstruction typing comes from the registry's
+`VStructEta.WF` certificate; the equality is precisely the primitive Theory
+rule. -/
+theorem StructureEtaArtifact.eta
+    (self : StructureEtaArtifact env familyName familyInfo constructorName
+      constructorInfo venv)
+    {U : Nat} {Γ : List VExpr} {levels : List VLevel}
+    {params : List VExpr} {major : VExpr}
+    (hΓ : OnCtx Γ (venv.IsType U))
+    (hlevels : ∀ level ∈ levels, level.WF U)
+    (hlevelsLength : levels.length = self.projection.view.uvars)
+    (hparamsLength : params.length = self.projection.view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      venv.SpineWF U Γ
+        (self.projection.view.familyType.instL levels)
+        params (.sort resultLevel))
+    (hmajor : venv.HasType U Γ major
+      (self.projection.view.structureType levels params)) :
+    venv.IsDefEq U Γ
+      (self.projection.view.etaRebuild levels params major) major
+      (self.projection.view.structureType levels params) := by
+  let rule := self.projection.viewWF.toStructEta self.etaOrdered
+  have hruleWF : rule.WF venv :=
+    self.etaOrdered.structEtaWF self.etaRegistered
+  obtain ⟨resultLevel, hparamsSpine⟩ := hparamsSpine
+  have hrebuild := hruleWF.rebuild_hasType VEnv.LE.rfl hΓ hlevels
+    hlevelsLength hparamsLength ⟨resultLevel, hparamsSpine⟩ hmajor
+  have heta := VEnv.IsDefEq.structEta self.etaRegistered hlevels
+    hlevelsLength hparamsLength hparamsSpine hmajor hrebuild
+  simpa [rule] using heta
+
+/-- Environments which contain no constructor metadata satisfy projection
+readiness vacuously.  This is the common staging case for validation fixtures:
+families may already be present, but their constructors have not been
+installed yet. -/
+theorem ProjectionReady.of_no_ctorInfo
+    (hnoCtor : ∀ name info,
+      env.find? name ≠ some (.ctorInfo info)) :
+    ProjectionReady env venv where
+  infer name _info hfind hready := by
+    have hfalse :=
+      Kernel.Environment.isProjectionReadyStructure_false_of_no_ctorInfo
+        hfind hnoCtor
+    rw [hfalse] at hready
+    contradiction
+  constructorNumParams _view info _hview hfind :=
+    (hnoCtor _ info hfind).elim
+
+/-- Environments with no constructor metadata also satisfy structure-eta
+readiness vacuously. -/
+theorem StructureEtaReady.of_no_ctorInfo
+    (hnoCtor : ∀ name info,
+      env.find? name ≠ some (.ctorInfo info)) :
+    StructureEtaReady env venv where
+  resolve _ _ constructorName constructorInfo _ hctor _ :=
+    (hnoCtor constructorName constructorInfo hctor).elim
+
+/-- A convenient negative readiness witness for staging/indexed environments
+where the host recognizes no eta-eligible structure family. -/
+theorem StructureEtaReady.of_no_nonRecStructure
+    (hnone : ∀ name, env.isNonRecStructure name = false) :
+    StructureEtaReady env venv where
+  resolve familyName _ _ _ _ _ hnonrec := by
+    rw [hnone familyName] at hnonrec
+    contradiction
+
 namespace TypeChecker
 
 inductive MLCtx where
@@ -193,6 +355,8 @@ structure VContext extends Context where
   safePrimitives : env.find? n = some ci →
     Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = []
   trenv : TrEnv safety env venv
+  projectionReady : ProjectionReady env venv
+  structureEtaReady : StructureEtaReady env venv
   mlctx : MLCtx
   mlctx_wf : mlctx.WF venv lparams
   lctx_eq : mlctx.lctx = lctx
@@ -315,7 +479,7 @@ structure Methods.WF (m : Methods) where
   isDefEqCore : c.TrExprS e₁ e₁' → c.TrExprS e₂ e₂' →
     (m.isDefEqCore e₁ e₂).WF c s fun b _ => b → c.IsDefEqU e₁' e₂'
   whnfCore : c.TrExprS e e' →
-    (m.whnfCore e cheapRec cheapProj).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e'
+    (m.whnfCore e cheapProj).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e'
   whnf : c.TrExprS e e' →
     (m.whnf e).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e'
   inferType : e.FVarsIn (· ∈ c.vlctx.fvars) →
@@ -847,6 +1011,13 @@ theorem MLCtx.WF.mkLambda_eq {c : MLCtx} (wf : c.WF env Us) (n hn)
 
 namespace Inner
 
+/-- A successful host-environment lookup returns exactly the constant found
+at the requested name.  Kept in the common checker layer so both inference
+and WHNF reduction can consume the same lookup certificate. -/
+theorem envGet.WF {c : VContext} :
+    (c.env.get name).WF fun ci => c.env.find? name = some ci := by
+  simp [Environment.get]; split <;> [refine .pure ‹_›; exact .throw]
+
 theorem whnf.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
     RecM.WF c s (whnf e) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' :=
   fun _ wf => wf.whnf he
@@ -880,7 +1051,7 @@ theorem checkType.WF {c : VContext} {s : VState} (h1 : e.FVarsIn (· ∈ c.vlctx
   inferType.WF' h1 nofun
 
 theorem whnfCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
-    RecM.WF c s (whnfCore e cheapRec cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' :=
+    RecM.WF c s (whnfCore e cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' :=
   fun _ wf => wf.whnfCore he
 
 theorem isDelta_is_some : isDelta env e = some ci ↔
@@ -917,7 +1088,7 @@ theorem unfoldDefinitionCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e'
     · exact (List.mapM_eq_some.1 a2).length_eq.symm.trans <| a3.trans b2.symm
   split <;> [rename_i h5; exact .pure this]
   refine .pureBind <| .get ?_
-  split <;> [rename_i eq; refine .pureBind ?_]
+  split <;> [rename_i eq; skip]
   · refine .stateWF fun wf => .pure ?_
     obtain ⟨_, _, _, ⟨⟩, a1, rfl⟩ := wf.unfold_wf eq
     cases h3.symm.trans a1; exact this
@@ -954,3 +1125,19 @@ theorem ensureSortCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
   · let .sort _ := e
     exact .pure ⟨⟨_, rfl⟩, he, hb⟩
   exact .getEnv <| .getLCtx .throw
+
+theorem getSortLevel.WF
+    (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ =>
+      ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by
+  refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_
+  refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_
+  obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h
+  let .sort hu := h3
+  exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩
+
+theorem isProp.WF
+    (he : c.TrExprS e e') : (isProp e).WF c s fun b _ =>
+      b → c.HasType e' (.sort .zero) := by
+  refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_
+  exact h.defeqU_r c.Ewf c.Δwf
+    ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩
diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean
index da5b6f01..1dd8e012 100644
--- a/Lean4Lean/Verify/TypeChecker/InferType.lean
+++ b/Lean4Lean/Verify/TypeChecker/InferType.lean
@@ -40,10 +40,6 @@ theorem inferFVar.WF {c : VContext} :
     c.trlctx.find?_of_mem c.Ewf (List.mem_of_find?_eq_some h)
   exact ⟨_, _, h2, .fvar h1, h3, c.Δwf.find?_wf c.Ewf h1⟩
 
-theorem envGet.WF {c : VContext} :
-    (c.env.get name).WF fun ci => c.env.find? name = some ci := by
-  simp [Environment.get]; split <;> [refine .pure ‹_›; exact .throw]
-
 theorem inferConstant.WF {c : VContext}
     (H : ∀ l ∈ ls, l.hasMVar' = false)
     (hinf : inferOnly = true → ∃ e', c.TrExprS (.const name ls) e') :
@@ -385,10 +381,569 @@ theorem inferLet.WF
   refine (c.withMLC_self ▸ inferLet.loop.WF (Nat.zero_le _) [] rfl rfl rfl rfl rfl ?_ hr) hinf
   exact fun P hP he => ⟨(AllAbove.wf wf.trctx.wf.fvwf).2 hP, he.mono fun _ h _ => h, fun _ => id⟩
 
+theorem AppStack.toSpineWF {c : VContext}
+    (H : AppStack c.venv c.lparams c.vlctx f f' args)
+    (hf : c.HasType f' (VExpr.forallN As C))
+    (hlen : args.length = As.length) :
+    ∃ args', args.Forall₂ (c.TrExprS · ·) args' ∧
+      c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+        (VExpr.forallN As C) args' (VExpr.instRev C args') ∧
+      c.TrExprS (f.mkAppList args) (VExpr.appN f' args') := by
+  induction args generalizing f f' As C with
+  | nil =>
+      cases As with
+      | nil =>
+          let .head hfull := H
+          exact ⟨[], .nil, .nil, by simpa⟩
+      | cons _ _ => simp at hlen
+  | cons arg args ih =>
+      cases As with
+      | nil => simp at hlen
+      | cons A As =>
+        let .app hfun harg hf' harg' Hrest := H
+        have htypes := hf.uniqU c.Ewf c.Δwf hfun
+        have ⟨⟨_, hA⟩, _⟩ := htypes.forallE_inv c.Ewf c.Δwf
+        have hargA := harg.defeqU_r c.Ewf c.Δwf ⟨_, hA.symm⟩
+        have hlen' : args.length = As.length := by simpa using hlen
+        have htailType : c.HasType (.app f' _) ((VExpr.forallN As C).inst _) :=
+          hf.app hargA
+        rw [VExpr.instN_forallN] at htailType
+        obtain ⟨args', hargs', hspine, hfull⟩ :=
+          ih Hrest htailType (by simpa [VExpr.instTelN_length] using hlen')
+        refine ⟨_ :: args', .cons harg' hargs', .cons hargA ?_, ?_⟩
+        have hlenArgsAs : args'.length = As.length :=
+          hargs'.length_eq.symm.trans hlen'
+        rw [VExpr.instN_forallN]
+        simpa [VExpr.instRev, hlenArgsAs] using hspine
+        simpa [Expr.mkAppList, VExpr.appN] using hfull
+
+theorem invalidProj.WF {c : VContext} {s : VState} :
+    (invalidProj e : RecM α).WF c s Q := by
+  unfold invalidProj
+  exact .getEnv <| .getLCtx .throw
+
+theorem inferProjParams.WF {c : VContext} {s : VState}
+    (hargs : args.Forall₂ (c.TrExprS · ·) args')
+    (hrBelow : c.FVarsBelow proj r)
+    (hargsBelow : ∀ arg ∈ args, c.FVarsBelow proj arg)
+    (hr : c.TrExpr r R)
+    (hspine : c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+      R args' T) :
+    (inferProjParams proj args r).WF c s fun out _ =>
+      c.FVarsBelow proj out ∧ c.TrExpr out T := by
+  induction hargs generalizing r R s with
+  | nil =>
+      simp [inferProjParams] at hspine ⊢
+      exact hspine.nil_inv ▸ .pure ⟨hrBelow, hr⟩
+  | @cons arg arg' args args' harg hargs ih =>
+      simp only [inferProjParams]
+      have hargBelow := hargsBelow arg (by simp)
+      have hargsBelow' : ∀ arg ∈ args, c.FVarsBelow proj arg := by
+        intro arg harg
+        exact hargsBelow arg (by simp [harg])
+      obtain ⟨A, B, rfl, hargType, hrest⟩ := hspine.cons_inv
+      obtain ⟨r', hrS, hrEq⟩ := hr
+      refine (whnf.WF hrS).bind fun out s' _
+        ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_
+      have houtEq := houtEq.trans c.Ewf c.Δwf hrEq
+      cases out with
+      | forallE name dom body bi =>
+        let .forallE hdomTy hbodyTy hdom hbody := hout
+        have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf
+        obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq
+        have hargType' := hargType.defeqU_r c.Ewf c.Δwf
+          ⟨_, hdomEq.symm⟩
+        have hnext : c.TrExpr (body.instantiate1 arg) (B.inst arg') := by
+          simpa only [Expr.instantiate1_eq] using
+            (.inst c.Ewf c.Δwf hargType'
+              ⟨_, hbody, _, hbodyEq⟩ (harg.trExpr c.Ewf c.Δwf))
+        have hnextBelow : c.FVarsBelow proj (body.instantiate1 arg) := by
+          intro P hP hproj
+          have houtFVars := (hrBelow.trans houtBelow) P hP hproj
+          simpa only [Expr.instantiate1_eq] using
+            houtFVars.2.instantiate1 (hargBelow P hP hproj)
+        exact ih hnextBelow hargsBelow' hnext hrest
+      | bvar | fvar | mvar | sort | const | app | lam | letE | lit |
+          mdata | proj => exact invalidProj.WF
+
+theorem inferProjFields.WF {c : VContext} {s : VState}
+    {view : VStructureView} {levels : List VLevel}
+    {params : List VExpr} {major : VExpr} {tailResult cursor : VExpr}
+    (hstruct : c.TrExprS struct major)
+    (hview : view.WF c.venv)
+    (hlevels : ∀ level ∈ levels, level.WF c.lparams.length)
+    (hlevelsLength : levels.length = view.uvars)
+    (hparamsLength : params.length = view.nparams)
+    (hparamsSpine : ∃ resultLevel,
+      c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+        (view.familyType.instL levels) params (.sort resultLevel))
+    (hprograms : view.ProgramsWF c.venv)
+    (hname : view.name = typeName)
+    (hmajor : c.HasType major (view.structureType levels params))
+    (hrBelow : c.FVarsBelow proj r)
+    (hstructBelow : c.FVarsBelow proj struct)
+    (hbound : fieldIdx + count <
+      (view.specializedFields levels params).length)
+    (hr : c.TrExpr r cursor)
+    (hcursor : VExpr.consumeForalls?
+      (VExpr.forallN (view.specializedFields levels params) tailResult)
+      (view.projectionArgs levels params fieldIdx major) = some cursor) :
+    (inferProjFields proj typeName struct maybePropType fieldIdx count r).WF
+      c s fun out _ =>
+        ∃ cursor',
+          VExpr.consumeForalls?
+            (VExpr.forallN (view.specializedFields levels params) tailResult)
+            (view.projectionArgs levels params (fieldIdx + count) major) =
+              some cursor' ∧
+          c.FVarsBelow proj out ∧ c.TrExpr out cursor' := by
+  induction count generalizing s r cursor fieldIdx with
+  | zero =>
+      simp only [inferProjFields, Nat.add_zero]
+      exact .pure ⟨cursor, hcursor, hrBelow, hr⟩
+  | succ count ih =>
+      simp only [inferProjFields]
+      have hfieldIdx : fieldIdx <
+          (view.specializedFields levels params).length := by omega
+      have hcodeIdx : fieldIdx <
+          (view.projectionCodes levels params).length := by
+        simpa using hfieldIdx
+      let code := (view.projectionCodes levels params)[fieldIdx]
+      have hcode :
+          (view.projectionCodes levels params)[fieldIdx]? = some code :=
+        List.getElem?_eq_getElem hcodeIdx
+      have hargsLength :
+          (view.projectionArgs levels params fieldIdx major).length =
+            fieldIdx :=
+        view.projectionArgs_length levels params fieldIdx major
+          (Nat.le_of_lt hcodeIdx)
+      obtain ⟨field, semanticBody, hfield, hconsume⟩ :=
+        VExpr.consumeForalls?_forallN_domain
+          (view.specializedFields levels params) tailResult
+          (view.projectionArgs levels params fieldIdx major)
+          (by simpa [hargsLength] using hfieldIdx)
+      rw [hargsLength] at hfield
+      have hcursorShape : cursor =
+          .forallE
+            (field.instRevAt
+              (view.projectionArgs levels params fieldIdx major) 0)
+            semanticBody :=
+        Option.some.inj (hcursor.symm.trans hconsume)
+      subst cursor
+      obtain ⟨field', typeBody, hfield', htypeFn,
+          hprojectorField⟩ :=
+        hprograms.projector_hasType_field c.Ewf c.Δwf hlevels
+          hlevelsLength hparamsLength hparamsSpine hcode hmajor
+      have hfieldEq : field' = field :=
+        Option.some.inj (hfield'.symm.trans hfield)
+      subst field'
+      have hprojector := hprograms c.Δwf hlevels hlevelsLength
+        hparamsLength hparamsSpine hcode
+      have hprojSem : c.venv.TrProj c.lparams.length c.vlctx.toCtx
+          view levels params fieldIdx major (.app code.projector major) := {
+        viewWF := hview
+        levelsWF := hlevels
+        levels_length := hlevelsLength
+        params_length := hparamsLength
+        paramsSpine := hparamsSpine
+        majorType := hmajor
+        program := ⟨code, hcode, rfl, hprojector⟩ }
+      have hprojStrict : c.TrExprS (.proj typeName fieldIdx struct)
+          (.app code.projector major) :=
+        .proj hstruct ⟨view, levels, params, hname, hprojSem⟩
+      obtain ⟨r', hrS, hrEq⟩ := hr
+      refine (whnf.WF hrS).bind fun out nextState _
+        ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_
+      have houtEq := houtEq.trans c.Ewf c.Δwf hrEq
+      cases out with
+      | forallE name dom body bi =>
+        let .forallE hdomTy hbodyTy hdom hbody := hout
+        have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf
+        obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq
+        have hprojectorField' := hprojectorField.defeqU_r
+          c.Ewf c.Δwf ⟨_, hdomEq.symm⟩
+        have hnext : c.TrExpr
+            (body.instantiate1 (.proj typeName fieldIdx struct))
+            (semanticBody.inst (.app code.projector major)) := by
+          simpa only [Expr.instantiate1_eq] using
+            (.inst c.Ewf c.Δwf hprojectorField'
+              ⟨_, hbody, _, hbodyEq⟩
+              (hprojStrict.trExpr c.Ewf.ordered c.Δwf))
+        have hnextBelow : c.FVarsBelow proj
+            (body.instantiate1 (.proj typeName fieldIdx struct)) := by
+          intro P hP hproj
+          have houtFVars := (hrBelow.trans houtBelow) P hP hproj
+          have hfieldProj : FVarsIn P
+              (.proj typeName fieldIdx struct) := by
+            simpa [FVarsIn] using hstructBelow P hP hproj
+          simpa only [Expr.instantiate1_eq] using
+            houtFVars.2.instantiate1 hfieldProj
+        have hconsumeNext : VExpr.consumeForalls?
+            (VExpr.forallN (view.specializedFields levels params) tailResult)
+            (view.projectionArgs levels params (fieldIdx + 1) major) =
+              some (semanticBody.inst (.app code.projector major)) := by
+          rw [view.projectionArgs_succ levels params fieldIdx major hcode]
+          rw [VExpr.consumeForalls?_append, hconsume]
+          rfl
+        have hbound' : fieldIdx + 1 + count <
+            (view.specializedFields levels params).length := by omega
+        have hrec (recState : VState) :=
+          ih (s := recState) hnextBelow hbound' hnext hconsumeNext
+        simp only
+        split
+        · refine (isProp.WF hdom).bind fun _ propState _ _ => ?_
+          split
+          · exact invalidProj.WF
+          · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm,
+              Nat.add_comm] using hrec propState
+        · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm,
+            Nat.add_comm] using hrec nextState
+      | bvar | fvar | mvar | sort | const | app | lam | letE | lit |
+          mdata | proj => exact invalidProj.WF
+
 theorem inferProj.WF
-    (he : c.TrExprS e e') (hty : c.TrExprS ety ety') (hasty : c.HasType e' ty') :
+    (heBelow : c.FVarsBelow e ety)
+    (he : c.TrExprS e e') (hty : c.TrExprS ety ety')
+    (hasty : c.HasType e' ety') :
     (inferProj st i e ety).WF c s fun ty _ =>
-      ∃ ty', c.TrTyping (.proj st i e) ty e' ty' := sorry
+      ∃ proj' ty', c.TrTyping (.proj st i e) ty proj' ty' := by
+  unfold inferProj
+  refine (whnf.WF hty).bind fun type _ _ ⟨htypeBelow, htype⟩ => ?_
+  have hprojBelowType : c.FVarsBelow (.proj st i e) type := by
+    intro P hP hproj
+    exact htypeBelow P hP (heBelow P hP (by simpa [FVarsIn] using hproj))
+  obtain ⟨type', htypeS, htypeEq⟩ := htype
+  rw [Expr.withApp_eq]
+  have ⟨family', hstack⟩ := AppStack.build
+    (type.mkAppList_getAppArgsList ▸ htypeS)
+  simp only
+  split
+  · rename_i familyName familyLevels hfamilyShape
+    refine .getEnv ?_
+    split
+    · exact invalidProj.WF
+    · rename_i hname
+      refine (M.WF.liftExcept envGet.WF).lift.bind fun ci _ _ hfind => ?_
+      split
+      · rename_i info
+        split
+        · rename_i constructor hctors
+          split
+          · rename_i hready
+            split
+            · exact invalidProj.WF
+            · rename_i hargs
+              obtain ⟨artifact⟩ :=
+                c.projectionReady.infer familyName info hfind hready
+              have hhead := hstack.tr
+              rw [hfamilyShape] at hhead
+              let .const (us' := levels') hfamilyConst hlevelsMap
+                hlevelsLength := hhead
+              have hviewFamily := artifact.viewWF.family
+              rw [artifact.name_eq] at hviewFamily
+              rw [hviewFamily] at hfamilyConst
+              cases hfamilyConst
+              have hlevelsWF : ∀ level ∈ levels',
+                  level.WF c.lparams.length :=
+                VLevel.WF.of_mapM_ofLevel hlevelsMap
+              have hlevelsSourceLength : levels'.length =
+                  artifact.view.generation.block.sourceType.uvars :=
+                (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans
+                  hlevelsLength
+              have hlevelsLength' : levels'.length = artifact.view.uvars := by
+                exact hlevelsSourceLength.trans
+                    artifact.view.generation.block.sourceType_uvars_eq
+              have hargsSize : type.getAppArgs.size =
+                  info.numParams + info.numIndices := by
+                simpa using hargs
+              have hargsLength : type.getAppArgsList.length =
+                  artifact.view.nparams := by
+                rw [← Expr.getAppArgs_toList]
+                simp [hargsSize,
+                  artifact.numParams_eq, artifact.numIndices_eq]
+              have hfamilyType : c.HasType (.const familyName levels')
+                  (artifact.view.familyType.instL levels') := by
+                exact VEnv.HasType.const hviewFamily hlevelsWF
+                  hlevelsSourceLength
+              have hfamilyTypeShape : c.HasType (.const familyName levels')
+                  (VExpr.forallN
+                    (artifact.view.generation.block.rawParams.map
+                      (VExpr.instL levels'))
+                    (artifact.view.generation.block.rawResult.instL
+                      levels')) := by
+                simpa [VStructureView.familyType,
+                  VInductDecl.NormalizedChecked.rawType_eq,
+                  artifact.view.raw_indices_eq,
+                  VExpr.instL_forallN, VExpr.forallN] using hfamilyType
+              have hargsRawLength : type.getAppArgsList.length =
+                  (artifact.view.generation.block.rawParams.map
+                    (VExpr.instL levels')).length := by
+                simpa [artifact.view.generation.shape.1] using hargsLength
+              obtain ⟨params', hparamsTr, hparamsSpineRaw, htypeFull⟩ :=
+                AppStack.toSpineWF hstack hfamilyTypeShape hargsRawLength
+              rw [type.mkAppList_getAppArgsList] at htypeFull
+              have htypeAppliedEq := htypeFull.uniq c.Ewf
+                (.refl c.Ewf c.Δwf) htypeS
+              have hmajorType : c.HasType e'
+                  (artifact.view.structureType levels' params') := by
+                apply hasty.defeqU_r c.Ewf c.Δwf
+                have := (htypeAppliedEq.trans c.Ewf c.Δwf htypeEq).symm
+                simpa [VStructureView.structureType,
+                  artifact.name_eq] using this
+              have hparamsLength : params'.length =
+                  artifact.view.nparams :=
+                hparamsTr.length_eq.symm.trans hargsLength
+              have hparamsRawLength : params'.length =
+                  (artifact.view.generation.block.rawParams.map
+                    (VExpr.instL levels')).length :=
+                hparamsTr.length_eq.symm.trans hargsRawLength
+              have hparamsSpine : ∃ resultLevel,
+                  c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+                    (artifact.view.familyType.instL levels') params'
+                    (.sort resultLevel) := by
+                obtain ⟨resultLevel, hresultLevel⟩ := artifact.rawResult_sort
+                refine ⟨resultLevel.inst levels', ?_⟩
+                rw [hresultLevel] at hparamsSpineRaw
+                rw [VExpr.instRev_closedN params' (by trivial)] at hparamsSpineRaw
+                simpa [VStructureView.familyType,
+                  VInductDecl.NormalizedChecked.rawType_eq,
+                  artifact.view.raw_indices_eq, hresultLevel,
+                  VExpr.instL_forallN, VExpr.forallN,
+                  VExpr.instRev, VExpr.instL] using hparamsSpineRaw
+              have hconstructorName :
+                  constructor = artifact.view.constructorName := by
+                have := hctors.symm.trans artifact.ctors_eq
+                simpa using this
+              refine (M.WF.liftExcept envGet.WF).lift.bind
+                fun c_info _ _ hctorFind => ?_
+              cases c_info with
+              | ctorInfo ctorInfo =>
+                simp only
+                split
+                · rename_i hidxHost
+                  have hctorInfoEq :
+                      ctorInfo = artifact.constructorInfo := by
+                    rw [hconstructorName, artifact.constructor_find] at hctorFind
+                    exact ConstantInfo.ctorInfo.inj
+                      (Option.some.inj hctorFind.symm)
+                  have hiFields : i <
+                      (artifact.view.specializedFields levels' params').length := by
+                    rw [hctorInfoEq,
+                      artifact.constructor_numFields_eq] at hidxHost
+                    simpa [VStructureView.specializedFields,
+                      VStructureView.fields] using hidxHost
+                  have hviewConstructor : c.venv.constants constructor =
+                      some artifact.view.constructor.raw.toVConstant := by
+                    simpa [hconstructorName] using
+                      artifact.viewWF.toRegistered.constructor
+                  obtain ⟨_, hctorTr⟩ :=
+                    c.trenv.find?_uniq hctorFind hviewConstructor
+                  have hrawCtorUvars :
+                      artifact.view.constructor.raw.uvars =
+                        artifact.view.uvars := by
+                    exact artifact.view.generation.ctor_uvars_eq
+                      (by simp [artifact.view.constructor_eq])
+                  have hctorLevelLength :
+                      ctorInfo.levelParams.length = familyLevels.length :=
+                    hctorTr.2.1.trans <| hrawCtorUvars.trans <|
+                      hlevelsLength'.symm.trans
+                        (List.mapM_eq_some.1 hlevelsMap).length_eq.symm
+                  have hctorType₀ := hctorTr.2.2.instL c.Ewf
+                    (Us := c.lparams) (ls' := levels') (Δ := [])
+                    trivial hlevelsMap hctorLevelLength
+                  have hctorType := hctorType₀.weakFV c.Ewf
+                    (.from_nil c.mlctx.noBV) c.Δwf
+                  rw [(c.Ewf.ordered.closedC
+                    hviewConstructor).instL.liftN_eq
+                      (Nat.le_refl _)] at hctorType
+                  let ctorTail := VExpr.forallN
+                    (artifact.view.fields.map (VExpr.instL levels'))
+                    ((artifact.view.constructor.rawResult
+                      artifact.view.nparams).instL levels')
+                  rw [artifact.view.constructor.rawType_eq] at hctorType
+                  have hinstantiate :
+                      ((.ctorInfo ctorInfo : ConstantInfo)
+                        |>.instantiateTypeLevelParams familyLevels) =
+                      ctorInfo.type.instantiateLevelParams
+                        ctorInfo.levelParams familyLevels := rfl
+                  have hctorTypeShape : c.TrExpr
+                      ((.ctorInfo ctorInfo : ConstantInfo)
+                        |>.instantiateTypeLevelParams familyLevels)
+                      (VExpr.forallN
+                        (artifact.view.constructorParams.map
+                          (VExpr.instL levels')) ctorTail) := by
+                    simpa [ConstantInfo.instantiateTypeLevelParams,
+                      ConstantVal.instantiateTypeLevelParams,
+                      ConstantInfo.type, ConstantInfo.toConstantVal, ctorTail,
+                      VInductDecl.NormalizedCtor.declaredBinders,
+                      VStructureView.nparams,
+                      VStructureView.constructorParams,
+                      VStructureView.fields,
+                      VExpr.instL_forallN, VExpr.forallN_append,
+                      List.map_append] using hctorType
+                  have hctorTypeBelow : c.FVarsBelow (.proj st i e)
+                      ((.ctorInfo ctorInfo : ConstantInfo)
+                        |>.instantiateTypeLevelParams familyLevels) := by
+                    intro P _ _
+                    simpa [ConstantInfo.instantiateTypeLevelParams,
+                      ConstantVal.instantiateTypeLevelParams,
+                      ConstantInfo.type, ConstantInfo.toConstantVal] using
+                        hctorType₀.fvarsIn.mono nofun
+                  have hparamArgsEq :
+                      List.take info.numParams type.getAppArgs.toList =
+                        type.getAppArgsList := by
+                    simp [Expr.getAppArgs_toList, artifact.numParams_eq,
+                      ← hargsLength]
+                  have hparamArgsTr :
+                      (List.take info.numParams
+                        type.getAppArgs.toList).Forall₂
+                        (c.TrExprS · ·) params' := by
+                    simpa [hparamArgsEq] using hparamsTr
+                  have hparamArgsBelow : ∀ arg ∈
+                      List.take info.numParams type.getAppArgs.toList,
+                      c.FVarsBelow (.proj st i e) arg := by
+                    intro arg harg P hP hproj
+                    apply FVarsIn.getAppArgsList
+                      (hprojBelowType P hP hproj)
+                    simpa [hparamArgsEq] using harg
+                  have hctorParamsSpine :=
+                    artifact.viewWF.constructorParamsSpine c.Ewf.ordered
+                      levels' hlevelsWF hlevelsLength' params' hparamsLength
+                      hparamsSpine ctorTail
+                  refine (inferProjParams.WF hparamArgsTr hctorTypeBelow
+                    hparamArgsBelow hctorTypeShape hctorParamsSpine).bind
+                      fun r _ _ hr => ?_
+                  obtain ⟨hrBelow, hr⟩ := hr
+                  let tailResult :=
+                    ((artifact.view.constructor.rawResult
+                      artifact.view.nparams).instL levels').instRevAt
+                        params' artifact.view.fields.length
+                  have hctorTailInst : ctorTail.instRev params' =
+                      VExpr.forallN
+                        (artifact.view.specializedFields levels' params')
+                        tailResult := by
+                    simp [ctorTail, tailResult,
+                      VExpr.instRev_forallN_projection,
+                      VStructureView.specializedFields,
+                      VExpr.instRevAt_map_instL_zipIdx]
+                  rw [hctorTailInst] at hr
+                  refine (getSortLevel.WF htypeS).bind
+                    fun sortLevel nextState _ _ => ?_
+                  have hstructBelow : c.FVarsBelow (.proj st i e) e := by
+                    intro P _ hproj
+                    simpa [FVarsIn] using hproj
+                  have hcursorZero : VExpr.consumeForalls?
+                      (VExpr.forallN
+                        (artifact.view.specializedFields levels' params')
+                        tailResult)
+                      (artifact.view.projectionArgs levels' params' 0 e') =
+                        some (VExpr.forallN
+                          (artifact.view.specializedFields levels' params')
+                          tailResult) := by
+                    rfl
+                  refine (inferProjFields.WF he artifact.viewWF hlevelsWF
+                    hlevelsLength' hparamsLength hparamsSpine
+                    artifact.programsWF artifact.name_eq hmajorType
+                    hrBelow hstructBelow (by simpa using hiFields) hr
+                    hcursorZero).bind
+                      fun r _ _ hr => ?_
+                  obtain ⟨cursor, hcursor, hrBelow, hr⟩ := hr
+                  have hcursor' : VExpr.consumeForalls?
+                      (VExpr.forallN
+                        (artifact.view.specializedFields levels' params')
+                        tailResult)
+                      (artifact.view.projectionArgs levels' params' i e') =
+                        some cursor := by
+                    simpa using hcursor
+                  have hcodeIdx : i <
+                      (artifact.view.projectionCodes levels' params').length := by
+                    simpa using hiFields
+                  let code :=
+                    (artifact.view.projectionCodes levels' params')[i]
+                  have hcode :
+                      (artifact.view.projectionCodes levels' params')[i]? =
+                        some code :=
+                    List.getElem?_eq_getElem hcodeIdx
+                  have hprojectionArgsLength :
+                      (artifact.view.projectionArgs levels' params' i e').length =
+                        i :=
+                    artifact.view.projectionArgs_length levels' params' i e'
+                      (Nat.le_of_lt hcodeIdx)
+                  obtain ⟨field, semanticBody, hfield, hconsume⟩ :=
+                    VExpr.consumeForalls?_forallN_domain
+                      (artifact.view.specializedFields levels' params')
+                      tailResult
+                      (artifact.view.projectionArgs levels' params' i e')
+                      (by simpa [hprojectionArgsLength] using hiFields)
+                  rw [hprojectionArgsLength] at hfield
+                  have hcursorShape : cursor =
+                      .forallE
+                        (field.instRevAt
+                          (artifact.view.projectionArgs levels' params' i e') 0)
+                        semanticBody :=
+                    Option.some.inj (hcursor'.symm.trans hconsume)
+                  subst cursor
+                  have hprograms : artifact.view.ProgramsWF c.venv :=
+                    artifact.programsWF
+                  obtain ⟨field', typeBody, hfield', htypeFn,
+                      hprojectorField⟩ :=
+                    hprograms.projector_hasType_field
+                      c.Ewf c.Δwf hlevelsWF hlevelsLength' hparamsLength
+                      hparamsSpine hcode hmajorType
+                  have hfieldEq : field' = field :=
+                    Option.some.inj (hfield'.symm.trans hfield)
+                  subst field'
+                  have hprojector := hprograms c.Δwf hlevelsWF
+                    hlevelsLength' hparamsLength hparamsSpine hcode
+                  have hprojSem : c.venv.TrProj c.lparams.length
+                      c.vlctx.toCtx artifact.view levels' params' i e'
+                      (.app code.projector e') := {
+                    viewWF := artifact.viewWF
+                    levelsWF := hlevelsWF
+                    levels_length := hlevelsLength'
+                    params_length := hparamsLength
+                    paramsSpine := hparamsSpine
+                    majorType := hmajorType
+                    program := ⟨code, hcode, rfl, hprojector⟩ }
+                  have hst : st = familyName := by
+                    simpa using hname
+                  have hprojStrict : c.TrExprS (.proj st i e)
+                      (.app code.projector e') :=
+                    .proj he ⟨artifact.view, levels', params',
+                      artifact.name_eq.trans hst.symm, hprojSem⟩
+                  obtain ⟨r', hrS, hrEq⟩ := hr
+                  refine (whnf.WF hrS).bind fun out _ _
+                    ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_
+                  have houtEq := houtEq.trans c.Ewf c.Δwf hrEq
+                  cases out with
+                  | forallE name dom body bi =>
+                    let .forallE hdomTy hbodyTy hdom hbody := hout
+                    have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf
+                    obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq
+                    have hprojectorField' := hprojectorField.defeqU_r
+                      c.Ewf c.Δwf ⟨_, hdomEq.symm⟩
+                    have hdomBelow : c.FVarsBelow (.proj st i e) dom := by
+                      intro P hP hproj
+                      exact ((hrBelow.trans houtBelow) P hP hproj).1
+                    have hresult : ∃ proj' ty',
+                        c.TrTyping (.proj st i e) dom proj' ty' :=
+                      ⟨.app code.projector e', _, hdomBelow, hprojStrict,
+                        hdom, hprojectorField'⟩
+                    simp only
+                    split
+                    · refine (isProp.WF hdom).bind fun _ _ _ _ => ?_
+                      split
+                      · exact invalidProj.WF
+                      · exact .pure hresult
+                    · exact .pure hresult
+                  | bvar | fvar | mvar | sort | const | app | lam | letE |
+                      lit | mdata | proj => exact invalidProj.WF
+                · exact invalidProj.WF
+              | axiomInfo | defnInfo | thmInfo | opaqueInfo | quotInfo |
+                  inductInfo | recInfo => exact invalidProj.WF
+          · exact invalidProj.WF
+        · exact invalidProj.WF
+      · exact invalidProj.WF
+  · exact invalidProj.WF
 
 theorem literal_is_primitive (H : n = ``Nat ∨ n = ``Char.ofNat ∨ n = ``String.ofList)  :
     Environment.primitives.contains n := by
@@ -414,7 +969,7 @@ theorem inferType'.WF
     (h1 : e.FVarsIn (· ∈ c.vlctx.fvars))
     (hinf : inferOnly = true → ∃ e', c.TrExprS e e') :
     (inferType' e inferOnly).WF c s fun ty _ => ∃ e' ty', c.TrTyping e ty e' ty' := by
-  unfold inferType'; lift_lets; intro F F1 F2 --; simp
+  unfold inferType'; lift_lets; intro F F1
   split <;> [exact .throw; refine .get <| .get ?_]
   split
   · rename_i h; refine .stateWF fun wf => .pure ?_
@@ -422,7 +977,7 @@ theorem inferType'.WF
     have : ic.WF c s := by
       subst ic; cases inferOnly <;> [exact wf.inferTypeC_wf; exact wf.inferTypeI_wf]
     exact (this h).2.2.2.2 h1
-  generalize hP : (fun ty:Expr => _) = P
+  generalize hP : (fun _ (_ : VState) => _) = P
   have hF {ty e' ty' s} (H : c.TrTyping e ty e' ty') : (F ty).WF c s P := by
     rintro _ mwf wf a s' ⟨⟩
     refine let s' := _; ⟨s', rfl, ?_⟩
@@ -436,7 +991,7 @@ theorem inferType'.WF
     subst P; revert s'; cases inferOnly <;> (dsimp -zeta; intro s'; refine ⟨.rfl, ?_, _, _, H⟩)
     · exact { wf with inferTypeC_wf := hic wf.inferTypeC_wf }
     · exact { wf with inferTypeI_wf := hic wf.inferTypeI_wf }
-  unfold F1; refine .get ?_; split
+  split
   · extract_lets G1; split <;> [split; skip]
     · refine .getEnv <| (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ h => ?_
       have ⟨_, h, _⟩ := c.trenv.find? h <|
@@ -457,7 +1012,7 @@ theorem inferType'.WF
     exact hF ⟨hb, .mdata h1, h⟩
   · refine (inferType'.WF (by exact h1) ?_).bind fun _ _ _ ⟨_, _, hb, h1, h2, h3⟩ => ?_
     · exact fun h => let ⟨_, .proj h ..⟩ := hinf h; ⟨_, h⟩
-    exact (inferProj.WF h1 h2 h3).bind fun ty _ _ ⟨ty', h⟩ => hF h
+    exact (inferProj.WF hb h1 h2 h3).bind fun ty _ _ ⟨_, ty', h⟩ => hF h
   · exact .readThe <| (M.WF.liftExcept inferFVar.WF).lift.bind fun _ _ _ ⟨_, _, h⟩ => hF h
   · exact .throw
   · rename_i h _; simp [Expr.hasLooseBVars, Expr.looseBVarRange'] at h
@@ -498,3 +1053,23 @@ theorem inferType'.WF
     subst hP; refine hF ⟨?_, .app hf3 ha3 hf1 ha1, hl4.inst c.Ewf ha3 ha1, .app hf3 ha3⟩
     exact fun _ hP he => (hfb.trans hb _ hP he.1).2.instantiate1 he.2
   · exact (inferLet.WF h1 hinf).bind fun _ _ _ ⟨_, _, h⟩ => hF h
+
+/--
+info: 'Lean4Lean.TypeChecker.Inner.inferProj.WF' depends on axioms: [propext,
+ sorryAx,
+ Classical.choice,
+ Quot.sound,
+ Expr.instantiate1_eq,
+ Expr.mkAppData_eq,
+ Expr.mkData_eq,
+ Expr.replace_eq,
+ Level.hasMVar_eq,
+ Level.hasParam_eq,
+ Level.instLawfulBEqLevel,
+ PersistentArray.toList'_push,
+ PersistentHashMap.findAux_isSome,
+ PersistentHashMap.WF.find?_eq,
+ PersistentHashMap.WF.toList'_insert]
+-/
+#guard_msgs in
+#print axioms inferProj.WF
diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean
index 7eddbada..be8db9e2 100644
--- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean
+++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean
@@ -1,4 +1,5 @@
 import Lean4Lean.Verify.TypeChecker.Reduce
+import Lean4Lean.Verify.TypeChecker.InferType
 import Lean4Lean.Verify.EquivManager
 
 open Lean4Lean
@@ -15,7 +16,7 @@ theorem isDefEqLambda.WF {c : VContext} {s : VState}
       b → (c.withMLC m).IsDefEqU ei₁' ei₂' := by
   unfold isDefEqLambda; let c' := c.withMLC m
   split <;> [rename_i n₁ d₁ b₁ bi₁ n₂ d₂ b₂ bi₂; (simp [hsubst]; exact isDefEq.WF he₁ he₂)]
-  extract_lets F di₁ di₂ G; unfold G di₁ di₂
+  extract_lets F di₁ di₂; unfold di₁ di₂
   simp at he₁ he₂
   let .lam (ty' := t₁') (body' := b₁') ⟨_, a1⟩ a2 a3 := he₁
   let .lam (ty' := t₂') (body' := b₂') b1 b2 b3 := he₂
@@ -85,7 +86,7 @@ theorem isDefEqForall.WF {c : VContext} {s : VState}
       b → (c.withMLC m).IsDefEqU ei₁' ei₂' := by
   unfold isDefEqForall; let c' := c.withMLC m
   split <;> [rename_i n₁ d₁ b₁ bi₁ n₂ d₂ b₂ bi₂; (simp [hsubst]; exact isDefEq.WF he₁ he₂)]
-  extract_lets F di₁ di₂ G; unfold G di₁ di₂
+  extract_lets F di₁ di₂; unfold di₁ di₂
   simp at he₁ he₂
   let .forallE (ty' := t₁') (body' := b₁') ⟨_, a1⟩ _ a2 a3 := he₁
   let .forallE (ty' := t₂') (body' := b₂') b1 ⟨_, bT⟩ b2 b3 := he₂
@@ -164,15 +165,14 @@ theorem quickIsDefEq.WF {c : VContext} {s : VState}
     · intro h; apply (VEnv.IsDefEqU.weak'_iff c.Ewf a1 a2.toCtx).1
       exact (h1 h).uniq c.Ewf (a2.bvars_eq.trans c.mlctx.noBV)
         a1 (he₁.weakFV' c.Ewf a2 a1) (he₂.weakFV' c.Ewf a2 a1)
-  extract_lets F; split <;> [exact .pure fun _ => h ‹_›; skip]
-  refine .pureBind ?_; unfold F; split
+  split <;> [exact .pure fun _ => h ‹_›; split]
   · exact .toLBoolM <| c.withMLC_self ▸
       isDefEqLambda.WF (subst := #[]) (fvs := []) rfl (c.withMLC_self ▸ he₁) (c.withMLC_self ▸ he₂)
   · exact .toLBoolM <| c.withMLC_self ▸
       isDefEqForall.WF (subst := #[]) (fvs := []) rfl (c.withMLC_self ▸ he₁) (c.withMLC_self ▸ he₂)
   · have .sort hu := he₁; have .sort hv := he₂
     refine .pure fun h => ⟨_, .sortDF (.of_ofLevel hu) (.of_ofLevel hv) ?_⟩
-    exact Level.isEquiv_wf (toLBool_true.1 h) hu hv
+    exact Level.isEquiv'_wf (toLBool_true.1 h) hu hv
   · let .mdata he₁ := he₁; let .mdata he₂ := he₂
     exact .toLBoolM <| isDefEq.WF he₁ he₂
   · cases he₁
@@ -223,9 +223,541 @@ theorem tryEtaExpansion.WF {c : VContext} {s : VState}
   split <;> [exact .pure fun _ => h rfl; skip]
   exact (tryEtaExpansionCore.WF he₂ he₁).mono fun _ _ _ h hb => (h hb).symm
 
+private theorem AppStack.toSpineWF_of_isType {c : VContext}
+    (H : AppStack c.venv c.lparams c.vlctx f f' args)
+    (hf : c.HasType f' (VExpr.forallN As (.sort resultLevel)))
+    (hfull : c.TrExprS (f.mkAppList args) full')
+    (hfullType : c.venv.IsType c.lparams.length c.vlctx.toCtx full') :
+    ∃ args', args.Forall₂ (c.TrExprS · ·) args' ∧
+      c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+        (VExpr.forallN As (.sort resultLevel)) args' (.sort resultLevel) ∧
+      c.TrExprS (f.mkAppList args) (VExpr.appN f' args') := by
+  induction args generalizing f f' As full' with
+  | nil =>
+    let .head hhead := H
+    cases As with
+    | nil =>
+      refine ⟨[], .nil, .nil, ?_⟩
+      change c.TrExprS f f'
+      exact hhead
+    | cons A As =>
+      obtain ⟨sortLevel, hfullSort⟩ := hfullType
+      have hheadEq := hhead.uniq c.Ewf (.refl c.Ewf c.Δwf) hfull
+      have hheadSort := hfullSort.defeqU_l c.Ewf c.Δwf hheadEq.symm
+      have htypes := hf.uniqU c.Ewf c.Δwf hheadSort
+      exact False.elim <|
+        VEnv.IsDefEqU.sort_forallE_inv c.Ewf c.Δwf htypes.symm
+  | cons arg args ih =>
+    let .app hfun harg hhead hargTr Hrest := H
+    cases As with
+    | nil =>
+      have htypes := hf.uniqU c.Ewf c.Δwf hfun
+      exact False.elim <|
+        VEnv.IsDefEqU.sort_forallE_inv c.Ewf c.Δwf htypes
+    | cons A As =>
+      have htypes := hf.uniqU c.Ewf c.Δwf hfun
+      obtain ⟨⟨_, hdomain⟩, _, _hcodomain⟩ :=
+        htypes.forallE_inv c.Ewf c.Δwf
+      have hargA := harg.defeqU_r c.Ewf c.Δwf ⟨_, hdomain.symm⟩
+      have htailType := hf.app hargA
+      rw [VExpr.instN_forallN] at htailType
+      obtain ⟨args', hargs, hspine, htailFull⟩ :=
+        ih Hrest htailType (by simpa [Expr.mkAppList] using hfull)
+          hfullType
+      refine ⟨_ :: args', .cons hargTr hargs, .cons hargA ?_, ?_⟩
+      · rw [VExpr.instN_forallN]
+        rw [Nat.zero_add]
+        rw [(show (VExpr.sort resultLevel).ClosedN 0 by trivial).instN_eq
+          (e2 := _) (Nat.zero_le As.length)]
+        exact hspine
+      · simpa [Expr.mkAppList, VExpr.appN] using htailFull
+
+private theorem forall₂_of_getElem? {R : α → β → Prop} :
+    ∀ {xs : List α} {ys : List β},
+      xs.length = ys.length →
+      (∀ (i : Nat) (x : α) (y : β),
+        xs[i]? = some x → ys[i]? = some y → R x y) →
+      List.Forall₂ R xs ys
+  | [], [], _, _ => .nil
+  | [], _ :: _, hlen, _ => by simp at hlen
+  | _ :: _, [], hlen, _ => by simp at hlen
+  | x :: xs, y :: ys, hlen, h => by
+      refine .cons (h 0 x y (by simp) (by simp)) ?_
+      apply forall₂_of_getElem? (Nat.succ.inj hlen)
+      intro i x' y' hx hy
+      exact h (i + 1) x' y' (by simpa using hx) (by simpa using hy)
+
+
+theorem tryEtaStructCore.WF_of_structureEta {c : VContext} {s : VState}
+    (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
+    RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := by
+  unfold tryEtaStructCore
+  split <;> [skip; exact .pure nofun]
+  refine .getEnv ?_
+  refine (M.WF.liftExcept envGet.WF).lift.bind fun _ci _ _ hfind => ?_
+  split <;> [skip; exact .pure nofun]
+  extract_lets F1 F2
+  split <;> [skip; exact .pure nofun]
+  rename_i hostHead ctorName ctorLevels hhead state hstate hostInfo ctorInfo
+    hargs
+  split <;> [skip; exact .pure nofun]
+  rename_i hnonrec
+  refine (inferType.WF he₁).bind fun _ _ _
+    ⟨ty₁', _aBelow, _aTerm, aType, aTyped⟩ => ?_
+  refine (inferType.WF he₂).bind fun _ _ _
+    ⟨ty₂', _bBelow, _bTerm, bType, bTyped⟩ => ?_
+  refine (isDefEq.WF aType bType).bind fun _ _ _ htypes => ?_
+  split <;> [skip; exact .pure nofun]
+  rename_i htypesTrue
+  unfold F1
+  obtain ⟨familyInfo, hfamily, ⟨artifact⟩⟩ :=
+    c.structureEtaReady.resolveConstructor hfind hnonrec
+  have ⟨head', hstack⟩ := AppStack.build <|
+    e₂.mkAppList_getAppArgsList ▸ he₂
+  have hheadTr := hstack.tr
+  rw [hhead] at hheadTr
+  let .const (us' := levels) hconst hlevelsMap hlevelsHostLength := hheadTr
+  have hviewConstructor := artifact.projection.viewWF.constructor
+  rw [artifact.constructor_name_eq] at hviewConstructor
+  rw [hviewConstructor] at hconst
+  cases hconst
+  have hlevelsWF : ∀ level ∈ levels,
+      level.WF c.lparams.length :=
+    VLevel.WF.of_mapM_ofLevel hlevelsMap
+  have hrawCtorUvars : artifact.projection.view.constructor.raw.uvars =
+      artifact.projection.view.uvars :=
+    artifact.projection.view.generation.ctor_uvars_eq
+      (by simp [artifact.projection.view.constructor_eq])
+  have hlevelsLength : levels.length = artifact.projection.view.uvars :=
+    (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans <|
+      hlevelsHostLength.trans hrawCtorUvars
+  have hctorHead : c.HasType (.const ctorName levels)
+      (artifact.projection.view.constructor.raw.type.instL levels) :=
+    VEnv.HasType.const hviewConstructor hlevelsWF
+      (hlevelsLength.trans hrawCtorUvars.symm)
+  let ctorBinders :=
+    (artifact.projection.view.constructor.declaredBinders
+      artifact.projection.view.nparams).map (VExpr.instL levels)
+  let ctorResult :=
+    (artifact.projection.view.constructor.rawResult
+      artifact.projection.view.nparams).instL levels
+  have hctorHeadShape : c.HasType (.const ctorName levels)
+      (VExpr.forallN ctorBinders ctorResult) := by
+    rw [artifact.projection.view.constructor.rawType_eq] at hctorHead
+    simpa [ctorBinders, ctorResult, VExpr.instL_forallN] using hctorHead
+  have hhostArgsLength : e₂.getAppArgsList.length =
+      ctorInfo.numParams + ctorInfo.numFields := by
+    simpa [Expr.getAppNumArgs_eq, ← Expr.getAppArgsList_reverse] using hargs
+  have hnumParams : ctorInfo.numParams = artifact.projection.view.nparams := by
+    exact (congrArg ConstructorVal.numParams
+      artifact.constructor_info_eq).symm.trans
+        artifact.projection.constructor_numParams_eq
+  have hnumFields : ctorInfo.numFields = artifact.projection.view.fields.length := by
+    exact (congrArg ConstructorVal.numFields
+      artifact.constructor_info_eq).symm.trans
+        artifact.projection.constructor_numFields_eq
+  have hconstructorMem : artifact.projection.view.constructor ∈
+      artifact.projection.view.generation.block.ctorPairs := by
+    simp [artifact.projection.view.constructor_eq]
+  have hconstructorShape :=
+    artifact.projection.view.generation.shape.2.2.2.2.2
+      artifact.projection.view.constructor hconstructorMem
+  have hhostBinderLength : e₂.getAppArgsList.length = ctorBinders.length := by
+    simpa [ctorBinders, VInductDecl.NormalizedCtor.declaredBinders,
+      VStructureView.fields, hnumParams, hnumFields,
+      hconstructorShape.2.2.1] using hhostArgsLength
+  obtain ⟨args', hargsTr, hargsSpine, hfullTr⟩ :=
+    AppStack.toSpineWF hstack hctorHeadShape hhostBinderLength
+  rw [e₂.mkAppList_getAppArgsList] at hfullTr
+  have hargsLength : args'.length = artifact.projection.view.nparams +
+      artifact.projection.view.fields.length :=
+    hargsTr.length_eq.symm.trans <| by
+      simpa [hnumParams, hnumFields] using hhostArgsLength
+  let params := args'.take artifact.projection.view.nparams
+  let fields := args'.drop artifact.projection.view.nparams
+  have hargsSplit : args' = params ++ fields := by
+    simpa [params, fields] using
+      (List.take_append_drop artifact.projection.view.nparams args').symm
+  have hparamsLength : params.length = artifact.projection.view.nparams := by
+    simp [params, hargsLength]
+  have hfieldsLength : fields.length = artifact.projection.view.fields.length := by
+    simp [fields, hargsLength]
+  have hargsSpineSplit := hargsSpine
+  rw [hargsSplit] at hargsSpineSplit
+  obtain ⟨paramCursor, hparamRaw, hfieldsRaw⟩ :=
+    hargsSpineSplit.split
+  let ctorTail := VExpr.forallN
+    (artifact.projection.view.fields.map (VExpr.instL levels)) ctorResult
+  have hparamCtor : c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+      (VExpr.forallN
+        (artifact.projection.view.constructorParams.map
+          (VExpr.instL levels)) ctorTail)
+      params paramCursor := by
+    simpa [ctorBinders, ctorTail,
+      VInductDecl.NormalizedCtor.declaredBinders,
+      VStructureView.constructorParams, VStructureView.fields,
+      List.map_append, VExpr.forallN_append] using hparamRaw
+  obtain ⟨resultLevel, hrawResult⟩ := artifact.projection.rawResult_sort
+  have hparamsSpine :=
+    artifact.projection.viewWF.familyParamsSpine_of_constructor
+      c.Ewf.ordered levels hlevelsWF hlevelsLength params hparamsLength
+      hparamCtor resultLevel hrawResult
+  have hdeclResult₀ :=
+    artifact.projection.viewWF.generationSemantics.constructor.declaredResult
+  have hdeclResult₁ := hdeclResult₀.instL hlevelsWF
+  have hdeclResult : c.venv.IsDefEq c.lparams.length
+      ctorBinders.reverse ctorResult
+      ((VInductDecl.NormalizedCtor.resultTarget
+        artifact.projection.view.generation.block
+        artifact.projection.view.constructor).instL levels)
+      ((VExpr.sort
+        artifact.projection.view.generation.block.checked.resultLevel).instL
+        levels) := by
+    simpa [ctorBinders, ctorResult, List.map_reverse] using hdeclResult₁
+  have hdeclTel₀ :=
+    artifact.projection.viewWF.generationSemantics.constructor.declaredTel
+  have hdeclTel := hdeclTel₀.instL hlevelsWF
+  have hctorOnTel : c.venv.OnTel c.lparams.length [] ctorBinders := by
+    simpa [ctorBinders] using hdeclTel.raw_onTel
+  have hctorCtxClosed : CtxClosed ctorBinders.reverse :=
+    VEnv.CtxWF.closed c.Ewf.ordered <| by
+      simpa using hctorOnTel.toOnCtx (by trivial)
+  have hdeclResultΓ := hdeclResult.weakR c.Ewf.ordered hctorCtxClosed
+    c.vlctx.toCtx
+  have hargsTelLength : args'.length = ctorBinders.length :=
+    hargsTr.length_eq.symm.trans hhostBinderLength
+  have hresultEq := hargsSpine.instRev_defeq c.Ewf.ordered
+    hargsTelLength hdeclResultΓ
+  let S := artifact.projection.viewWF.toGenerationEnv c.Ewf.ordered
+  have hresultIndices :
+      artifact.projection.view.constructor.view.resultIndices = [] := by
+    apply List.length_eq_zero_iff.1
+    rw [S.viewResultIndices_length hconstructorMem]
+    simp [artifact.projection.view.checked_indices_eq]
+  have hrange := VExpr.map_instRev_bvarRevRange_seg args'
+    artifact.projection.view.nparams artifact.projection.view.fields.length
+    (by omega)
+  have hrange' :
+      (VExpr.bvarRevRange
+        (artifact.projection.view.constructor.rawFields
+          artifact.projection.view.source.nparams).length
+        artifact.projection.view.source.nparams).map (VExpr.instRev · args') =
+      params := by
+    simpa [VStructureView.fields, hargsLength, params] using hrange
+  have htarget :
+      ((VInductDecl.NormalizedCtor.resultTarget
+        artifact.projection.view.generation.block
+        artifact.projection.view.constructor).instL levels).instRev args' =
+      artifact.projection.view.structureType levels params := by
+    simp only [VInductDecl.NormalizedCtor.resultTarget,
+      VExpr.instL_appN, VExpr.instL, VExpr.instRev_appN, VExpr.instRev,
+      VExpr.bvarRevRange_map_instL, hresultIndices, List.append_nil]
+    rw [VLevel.inst_map_id hlevelsLength]
+    rw [VExpr.instRev_closedN args' (by trivial)]
+    rw [hrange']
+    rfl
+  rw [htarget] at hresultEq
+  have hcanonicalRaw := hargsSpine.hasType_appN hctorHeadShape
+  have hcanonical : c.HasType
+      ((VExpr.const ctorName levels).appN args')
+      (artifact.projection.view.structureType levels params) :=
+    hcanonicalRaw.defeqU_r c.Ewf c.Δwf ⟨_, hresultEq⟩
+  have hfullEq := hfullTr.uniq c.Ewf (.refl c.Ewf c.Δwf) he₂
+  have hbStruct := hcanonical.defeqU_l c.Ewf c.Δwf hfullEq
+  have hty₂Struct := bTyped.uniqU c.Ewf c.Δwf hbStruct
+  have hty₁Struct := VEnv.IsDefEqU.trans c.Ewf c.Δwf
+    (htypes htypesTrue) hty₂Struct
+  have haStruct := aTyped.defeqU_r c.Ewf c.Δwf hty₁Struct
+  have heta := artifact.eta c.Δwf hlevelsWF hlevelsLength
+    hparamsLength ⟨_, hparamsSpine⟩ haStruct
+  have hF1Size : F1.size = args'.length := by
+    calc
+      F1.size = F1.toList.length := by simp
+      _ = e₂.getAppArgsList.length := by simp [F1, Expr.getAppArgs_toList]
+      _ = args'.length := hargsTr.length_eq
+  have hfieldData : ∀ (j : Nat), j < fields.length →
+      ∃ code : VStructureView.ProjectionCode,
+        (artifact.projection.view.projectionCodes levels params)[j]? =
+          some code ∧
+        c.TrExprS (.proj ctorInfo.induct j e₁)
+          (.app code.projector e₁') ∧
+        ∀ (hi : ctorInfo.numParams + j < F1.size),
+          c.TrExprS F1[ctorInfo.numParams + j] fields[j] := by
+    intro j hj
+    have hcodeIdx : j <
+        (artifact.projection.view.projectionCodes levels params).length := by
+      simpa [VStructureView.specializedFields, hfieldsLength] using hj
+    let code := (artifact.projection.view.projectionCodes levels params)[j]
+    have hcode :
+        (artifact.projection.view.projectionCodes levels params)[j]? =
+          some code := List.getElem?_eq_getElem hcodeIdx
+    have hprojector := artifact.projection.programsWF c.Δwf hlevelsWF
+      hlevelsLength hparamsLength ⟨_, hparamsSpine⟩ hcode
+    have hprojSem : c.venv.TrProj c.lparams.length c.vlctx.toCtx
+        artifact.projection.view levels params j e₁'
+        (.app code.projector e₁') := {
+      viewWF := artifact.projection.viewWF
+      levelsWF := hlevelsWF
+      levels_length := hlevelsLength
+      params_length := hparamsLength
+      paramsSpine := ⟨_, hparamsSpine⟩
+      majorType := haStruct
+      program := ⟨code, hcode, rfl, hprojector⟩ }
+    have hprojTr : c.TrExprS (.proj ctorInfo.induct j e₁)
+        (.app code.projector e₁') :=
+      .proj he₁ ⟨artifact.projection.view, levels, params,
+        artifact.projection.name_eq, hprojSem⟩
+    refine ⟨code, hcode, hprojTr, ?_⟩
+    intro hi
+    have hselectedList :
+        e₂.getAppArgsList[ctorInfo.numParams + j]? =
+          some F1[ctorInfo.numParams + j] := by
+      rw [← Expr.getAppArgs_toList]
+      simpa [F1] using List.getElem?_eq_getElem hi
+    obtain ⟨translated, htranslated, htr⟩ :=
+      Lean4Lean.List.Forall₂.getElem?_left hargsTr hselectedList
+    have hfieldGet : args'[ctorInfo.numParams + j]? = some fields[j] := by
+      rw [hargsSplit, List.getElem?_append_right]
+      · simpa [hnumParams, hparamsLength] using
+          (List.getElem?_eq_getElem hj)
+      · simpa [hnumParams, hparamsLength]
+    have : translated = fields[j] :=
+      Option.some.inj (htranslated.symm.trans hfieldGet)
+    subst translated
+    exact htr
+  rw [Std.Legacy.Range.forIn'_eq_forIn'_range']
+  simp only [Std.Legacy.Range.size, Nat.add_sub_cancel, Nat.div_one]
+  let FieldEq := fun (j : Nat) => ∃ (field : VExpr)
+      (code : VStructureView.ProjectionCode),
+    fields[j]? = some field ∧
+    (artifact.projection.view.projectionCodes levels params)[j]? = some code ∧
+    c.IsDefEqU (.app code.projector e₁') field
+  let etaStep (indices : List Nat)
+      (hlow : ∀ i, i ∈ indices → ctorInfo.numParams ≤ i)
+      (hhigh : ∀ i, i ∈ indices → i < F1.size) :
+      (i : Nat) → i ∈ indices → Option Bool × PUnit →
+        RecM (ForInStep (Option Bool × PUnit)) :=
+    fun i hi r => tryEtaStructFieldStep e₁ ctorInfo.induct
+      ctorInfo.numParams F1 i
+      ⟨hlow i hi, hhigh i hi, by
+        change (i - ctorInfo.numParams) % 1 = 0
+        exact Nat.mod_one _⟩ r
+  have etaLoopWF : ∀ (all indices : List Nat)
+      (hsuffix : ∃ pre, pre ++ indices = all)
+      (hlow : ∀ i, i ∈ all → ctorInfo.numParams ≤ i)
+      (hhigh : ∀ i, i ∈ all → i < F1.size) {st : VState},
+      RecM.WF c st
+        (List.forIn'.loop all (etaStep all hlow hhigh) indices
+          ⟨none, PUnit.unit⟩ hsuffix)
+        fun r _ =>
+          (r.1 = none →
+            ∀ i, i ∈ indices → FieldEq (i - ctorInfo.numParams)) ∧
+          r.1 ≠ some true := by
+    intro all indices hsuffix hlow hhigh st
+    induction indices generalizing st with
+    | nil =>
+      simp only [List.forIn'.loop]
+      exact .pure (by simp)
+    | cons i indices ih =>
+      simp only [List.forIn'.loop]
+      simp only [etaStep, tryEtaStructFieldStep]
+      obtain ⟨pre, hprefix⟩ := hsuffix
+      have hiAll : i ∈ all := by
+        rw [← hprefix]
+        simp
+      have hlo := hlow i hiAll
+      have hhi := hhigh i hiAll
+      have hj : i - ctorInfo.numParams < fields.length := by
+        rw [hF1Size, hargsLength, ← hnumParams,
+          ← hfieldsLength] at hhi
+        omega
+      obtain ⟨code, hcode, hprojTr, hargTr⟩ :=
+        hfieldData (i - ctorInfo.numParams) hj
+      have hiEq : ctorInfo.numParams + (i - ctorInfo.numParams) = i :=
+        Nat.add_sub_of_le hlo
+      have hargBound :
+          ctorInfo.numParams + (i - ctorInfo.numParams) < F1.size := by
+        omega
+      have hargTr' : c.TrExprS F1[i] fields[i - ctorInfo.numParams] := by
+        simpa [hiEq] using hargTr hargBound
+      simp only [bind_assoc]
+      refine (isDefEq.WF hprojTr hargTr').bind fun b next _ hb => ?_
+      by_cases hbtrue : b = true
+      · simp only [hbtrue, if_pos, pure_bind]
+        have hcur : FieldEq (i - ctorInfo.numParams) :=
+          ⟨fields[i - ctorInfo.numParams], code,
+            List.getElem?_eq_getElem hj, hcode, hb hbtrue⟩
+        have hsuffixTail : ∃ pre, pre ++ indices = all := by
+          refine ⟨pre ++ [i], ?_⟩
+          simpa [List.append_assoc] using hprefix
+        have htail : RecM.WF c next
+            (List.forIn'.loop all (etaStep all hlow hhigh) indices
+              ⟨none, PUnit.unit⟩ hsuffixTail)
+            (fun r _ =>
+              (r.1 = none →
+                ∀ k, k ∈ i :: indices →
+                  FieldEq (k - ctorInfo.numParams)) ∧
+              r.1 ≠ some true) :=
+          (ih hsuffixTail (st := next)).mono
+          (fun r _ _ hrest => ⟨fun hnone k hk => by
+              rw [List.mem_cons] at hk
+              rcases hk with rfl | hk
+              · exact hcur
+              · exact hrest.1 hnone k hk,
+            hrest.2⟩)
+        simpa only [etaStep, tryEtaStructFieldStep, pure_bind] using htail
+      · simp only [hbtrue, if_neg, pure_bind]
+        exact .pure (by simp)
+  have hparamsLe : ctorInfo.numParams ≤ F1.size := by
+    rw [hF1Size, hargsLength, ← hnumParams]
+    omega
+  have hlowRange : ∀ i,
+      i ∈ List.range' ctorInfo.numParams
+        (F1.size - ctorInfo.numParams) →
+      ctorInfo.numParams ≤ i := by
+    intro i hi
+    rcases List.mem_range'.mp hi with ⟨j, hj, rfl⟩
+    omega
+  have hhighRange : ∀ i,
+      i ∈ List.range' ctorInfo.numParams
+        (F1.size - ctorInfo.numParams) →
+      i < F1.size := by
+    intro i hi
+    rcases List.mem_range'.mp hi with ⟨j, hj, rfl⟩
+    omega
+  have etaForInWF : ∀ {st : VState}, RecM.WF c st
+      (List.forIn'
+        (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams))
+        ⟨none, PUnit.unit⟩
+        (etaStep
+          (List.range' ctorInfo.numParams
+            (F1.size - ctorInfo.numParams)) hlowRange hhighRange))
+      (fun r _ => (r.1 = none → ∀ i,
+          i ∈ List.range' ctorInfo.numParams
+            (F1.size - ctorInfo.numParams) →
+          FieldEq (i - ctorInfo.numParams)) ∧
+        r.1 ≠ some true) := by
+    intro st
+    exact etaLoopWF
+      (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams))
+      (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams))
+      ⟨[], by simp⟩ hlowRange hhighRange
+  change RecM.WF c _
+    (do
+      let r ← List.forIn'
+        (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams))
+        ⟨none, PUnit.unit⟩
+        (etaStep
+          (List.range' ctorInfo.numParams
+            (F1.size - ctorInfo.numParams)) hlowRange hhighRange)
+      match r.1 with
+      | none => pure true
+      | some a => pure a)
+    (fun b _ => b = true → c.IsDefEqU e₁' e₂')
+  refine etaForInWF.bind fun r next _ hr => ?_
+  cases hr₁ : r.1 with
+  | some b =>
+    simp only
+    refine .pure fun hbtrue => False.elim <|
+      hr.2 (hr₁.trans (congrArg some hbtrue))
+  | none =>
+    simp only
+    refine .pure fun _ => ?_
+    have hrangeCount :
+        F1.size - ctorInfo.numParams = fields.length := by
+      rw [hF1Size, hargsLength, hnumParams, hfieldsLength]
+      omega
+    have hfieldEq : ∀ j, j < fields.length → FieldEq j := by
+      intro j hj
+      have hjmem : ctorInfo.numParams + j ∈
+          List.range' ctorInfo.numParams
+            (F1.size - ctorInfo.numParams) := by
+        apply List.mem_range'.2
+        exact ⟨j, by simpa [hrangeCount] using hj, by simp⟩
+      simpa using hr.1 hr₁ (ctorInfo.numParams + j) hjmem
+    let projections := artifact.projection.view.projectionArgs levels params
+      (artifact.projection.view.specializedFields levels params).length e₁'
+    have hprojectionCount :
+        (artifact.projection.view.specializedFields levels params).length =
+          fields.length := by
+      simpa [VStructureView.specializedFields] using hfieldsLength.symm
+    have hprojectionsLength : projections.length = fields.length := by
+      dsimp [projections]
+      rw [artifact.projection.view.projectionArgs_length levels params
+        (artifact.projection.view.specializedFields levels params).length
+        e₁' (by simp)]
+      exact hprojectionCount
+    have hpointwise : List.Forall₂
+        (fun a a' => a = a' ∨ c.IsDefEqU a a') projections fields := by
+      apply forall₂_of_getElem? hprojectionsLength
+      intro j projection field hprojection hfield
+      have hj := (List.getElem?_eq_some_iff.mp hfield).1
+      obtain ⟨field', code, hfield', hcode, hdefeq⟩ := hfieldEq j hj
+      have hprojection' : projections[j]? =
+          some (.app code.projector e₁') := by
+        dsimp [projections, VStructureView.projectionArgs]
+        have hjspec : j <
+            (artifact.projection.view.specializedFields levels params).length :=
+          hprojectionCount.symm ▸ hj
+        rw [List.getElem?_map, List.getElem?_take_of_lt hjspec, hcode]
+        rfl
+      have hpEq : projection = .app code.projector e₁' :=
+        Option.some.inj (hprojection.symm.trans hprojection')
+      have hfEq : field = field' :=
+        Option.some.inj (hfield.symm.trans hfield')
+      subst projection
+      subst field
+      exact .inr hdefeq
+    let tailResult := VExpr.instRevAt ctorResult params
+      artifact.projection.view.fields.length
+    have hctorTailShape : VExpr.instRev ctorTail params =
+        VExpr.forallN
+          (artifact.projection.view.specializedFields levels params)
+          tailResult := by
+      simp only [ctorTail, tailResult, VExpr.instRev_forallN_projection,
+        VStructureView.specializedFields, List.length_map]
+      rw [VExpr.instRevAt_map_instL_zipIdx]
+    have hconstructorParamsLength : params.length =
+        artifact.projection.view.constructorParams.length := by
+      exact hparamsLength.trans <| by
+        simpa [VStructureView.constructorParams] using
+          hconstructorShape.2.2.1.symm
+    have hctorHeadPrefix : c.HasType (.const ctorName levels)
+        (VExpr.forallN
+          (artifact.projection.view.constructorParams.map
+            (VExpr.instL levels)) ctorTail) := by
+      simpa [ctorBinders, ctorTail,
+        VInductDecl.NormalizedCtor.declaredBinders,
+        VStructureView.constructorParams, VStructureView.fields,
+        List.map_append, VExpr.forallN_append] using hctorHeadShape
+    have hprefixSpine := hparamCtor.retarget
+      (by simpa using hconstructorParamsLength) ctorTail
+    rw [hctorTailShape] at hprefixSpine
+    have hprefixType := hprefixSpine.hasType_appN hctorHeadPrefix
+    have hprojectionSpine :=
+      VStructureView.ProgramsWF.projectionArgsSpine
+        artifact.projection.programsWF
+        c.Ewf c.Δwf hlevelsWF hlevelsLength hparamsLength
+        ⟨_, hparamsSpine⟩ haStruct tailResult
+    have hprojectionDefEq := hprojectionSpine.defEq_of_pointwise
+      c.Ewf c.Δwf (by simpa [projections] using hpointwise)
+    have happEq := VEnv.IsDefEq.appN_defEq hprefixType
+      hprojectionDefEq
+    have happEqU : c.IsDefEqU
+        (artifact.projection.view.etaRebuild levels params e₁')
+        ((VExpr.const ctorName levels).appN args') := by
+      refine ⟨VExpr.instRev tailResult projections, ?_⟩
+      simpa [VStructureView.etaRebuild, VExpr.appN_append,
+        artifact.constructor_name_eq, hargsSplit] using happEq
+    exact VEnv.IsDefEqU.trans c.Ewf c.Δwf
+      ⟨artifact.projection.view.structureType levels params, heta.symm⟩
+      (VEnv.IsDefEqU.trans c.Ewf c.Δwf happEqU hfullEq)
+
+
 theorem tryEtaStructCore.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
-    RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := sorry
+    RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' :=
+  tryEtaStructCore.WF_of_structureEta he₁ he₂
 
 theorem tryEtaStruct.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
@@ -238,14 +770,13 @@ theorem tryEtaStruct.WF {c : VContext} {s : VState}
 theorem isDefEqApp.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
     RecM.WF c s (isDefEqApp e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := by
-  unfold isDefEqApp; extract_lets F1
-  split <;> [(refine .pureBind ?_; unfold F1); exact .pure nofun]
+  unfold isDefEqApp; split <;> [skip; exact .pure nofun]
   rw [Expr.withApp_eq, Expr.withApp_eq]
   split <;> [rename_i eq; exact .pure nofun]
   have ⟨_, he₁'⟩ := AppStack.build <| e₁.mkAppList_getAppArgsList ▸ he₁
   have ⟨_, he₂'⟩ := AppStack.build <| e₂.mkAppList_getAppArgsList ▸ he₂
-  refine (isDefEq.WF he₁'.tr he₂'.tr).bind fun _ _ _ h => ?_; extract_lets F2
-  split <;> [(refine .pureBind ?_; unfold F2); exact .pure nofun]
+  refine (isDefEq.WF he₁'.tr he₂'.tr).bind fun _ _ _ h => ?_
+  split <;> [skip; exact .pure nofun]
   let rec loop.WF {s args₁ args₂ f₁ f₂ f₁' f₂' eq i} (l₁ r₁ l₂ r₂)
       (h₁ : args₁.toList = l₁ ++ r₁) (hi₁ : l₁.length = i)
       (h₂ : args₂.toList = l₂ ++ r₂) (hi₂ : l₂.length = i)
@@ -281,28 +812,13 @@ theorem isDefEqApp.WF {c : VContext} {s : VState}
   simp [Expr.getAppArgs_toList, Expr.mkAppList_getAppArgsList] at h2
   exact h2 hb _ he₁ _ he₂
 
-theorem getSortLevel.WF
-    (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ =>
-      ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by
-  refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_
-  refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_
-  obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h
-  let .sort hu := h3
-  exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩
-
-theorem isProp.WF
-    (he : c.TrExprS e e') : (isProp e).WF c s fun b _ => b → c.HasType e' (.sort .zero) := by
-  refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_
-  exact h.defeqU_r c.Ewf c.Δwf
-    ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩
-
 theorem isDefEqProofIrrel.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
     RecM.WF c s (isDefEqProofIrrel e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by
   unfold isDefEqProofIrrel
-  refine (inferType.WF he₁).bind fun _ _ _ ⟨_, a1, a2, a3, a4⟩ => ?_; extract_lets F1
+  refine (inferType.WF he₁).bind fun _ _ _ ⟨_, a1, a2, a3, a4⟩ => ?_
   refine (isProp.WF a3).bind fun _ _ _ h1 => ?_
-  split <;> [exact .pure nofun; (refine .pureBind ?_; unfold F1)]
+  split <;> [exact .pure nofun; skip]
   rename_i h; simp at h
   refine (inferType.WF he₂).bind fun _ _ _ ⟨_, b1, b2, b3, b4⟩ => .toLBoolM ?_
   refine (isDefEq.WF a3 b3).mono fun _ _ _ h2 hb => ?_
@@ -316,9 +832,8 @@ theorem cacheFailure.WF {c : VContext} {s : VState} :
 theorem tryUnfoldProjApp.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
     (tryUnfoldProjApp e).WF c s fun oe _ =>
     ∀ e₁, oe = some e₁ → c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by
-  unfold tryUnfoldProjApp; extract_lets f F
+  unfold tryUnfoldProjApp; extract_lets f
   split <;> [exact .pure nofun; skip]
-  refine .pureBind ?_; unfold F
   refine (whnfCore.WF he).bind fun _ _ _ h => ?_
   refine .pure fun _ => ?_
   split <;> rintro ⟨⟩; exact h
@@ -420,11 +935,11 @@ theorem isNatSuccOf?_wf {c : VContext} (H : isNatSuccOf? e = some e₁)
 theorem isDefEqOffset.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
     (isDefEqOffset e₁ e₂).WF c s fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by
-  unfold isDefEqOffset; extract_lets F; split
+  unfold isDefEqOffset; split
   · rename_i h; simp at h
     cases isNatZero_wf h.1 he₁; cases isNatZero_wf h.2 he₂
     exact .pure fun _ => .refl <| he₁.wf c.Ewf c.Δwf
-  · refine .pureBind ?_; unfold F; split <;> [skip; exact .pure nofun]
+  · split <;> [skip; exact .pure nofun]
     obtain ⟨_, a1, rfl⟩ := isNatSuccOf?_wf ‹_› he₁
     obtain ⟨_, b1, rfl⟩ := isNatSuccOf?_wf ‹_› he₂
     refine .toLBoolM <| (isDefEqCore.WF a1 b1).mono fun _ _ _ h hb => ?_
@@ -436,11 +951,11 @@ theorem lazyDeltaReduction.loop.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
     (lazyDeltaReduction.loop e₁ e₂ n).WF c s fun r _ => r.WF c e₁' e₂' := by
   induction n generalizing s e₁ e₂ e₁' e₂' with | zero => exact .throw | succ n ih
-  unfold loop; extract_lets F1 F2 F3
+  unfold loop; extract_lets F1
   refine (isDefEqOffset.WF he₁ he₂).bind fun _ _ _ h => ?_; split
   · exact .pure fun hb => h (by simpa using hb)
-  suffices hF2 : ∀ {s}, (F2 ⟨⟩).WF c s fun r _ => r.WF c e₁' e₂' by
-    refine .pureBind <|.readThe ?_; split <;> [skip; exact hF2]
+  suffices hF1 : ∀ {s}, (F1 ⟨⟩).WF c s fun r _ => r.WF c e₁' e₂' by
+    refine .readThe ?_; split <;> [skip; exact hF1]
     refine (reduceNat.WF he₁).bind fun _ _ _ h => ?_; split
     · have ⟨_, a1, a2⟩ := (h _ rfl).2
       refine (isDefEqCore.WF a1 he₂).bind fun _ _ _ h => .pure fun hb => ?_
@@ -449,13 +964,12 @@ theorem lazyDeltaReduction.loop.WF {c : VContext} {s : VState}
     · have ⟨_, a1, a2⟩ := (h _ rfl).2
       refine (isDefEqCore.WF he₁ a1).bind fun _ _ _ h => .pure fun hb => ?_
       exact (h hb).trans c.Ewf c.Δwf a2
-    exact hF2
-  intro s; unfold F2; refine .getEnv ?_
+    exact hF1
+  intro s; unfold F1; refine .getEnv ?_
   refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h => ?_
   split <;> [cases h _ rfl; skip]
   refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h => ?_
   split <;> [cases h _ rfl; skip]
-  refine .pureBind ?_; unfold F1
   refine (lazyDeltaReductionStep.WF he₁ he₂).bind fun r _ _ h => ?_
   obtain r|r|r := r
   · let ⟨_, ⟨_, a1, a2⟩, ⟨_, b1, b2⟩⟩ := h
@@ -477,18 +991,162 @@ theorem tryStringLitExpansion.WF {c : VContext} {s : VState}
   split <;> [skip; exact .pure h]
   exact (tryStringLitExpansionCore.WF he₂ he₁).mono fun _ _ _ h hb => (h hb).symm
 
+theorem isDefEqUnitLike.WF_of_structureEta {c : VContext} {s : VState}
+    (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
+    RecM.WF c s (isDefEqUnitLike e₁ e₂)
+      fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by
+  unfold isDefEqUnitLike
+  refine (inferType.WF he₁).bind fun _ _ _
+    ⟨ty₁', _aBelow, _aTerm, aType, aTyped⟩ => ?_
+  refine (whnf.WF aType).bind fun normalizedType _ _
+    ⟨_aWhnfBelow, tType', tTypeTr, tTypeEq⟩ => ?_
+  split <;> [skip; exact .pure nofun]
+  rename_i _ familyName hostLevels hhead
+  refine .getEnv ?_
+  refine (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ hfamily => ?_
+  split <;> [skip; exact .pure nofun]
+  rename_i _ familyDeclName familyLevelParams familyRawType hostNumParams
+    familyAll ctorName familyNumNested familyUnsafe familyReflexive
+  refine (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ hctor => ?_
+  split <;> [skip; exact .pure nofun]
+  rename_i _ ctorDeclName ctorLevelParams ctorRawType ctorInduct ctorIndex
+    ctorNumParams ctorUnsafe
+  refine (inferType.WF he₂).bind fun _ _ _
+    ⟨ty₂', _bBelow, _bTerm, bType, bTyped⟩ => ?_
+  refine (isDefEqCore.WF tTypeTr bType).mono fun _ _ _ h hb => ?_
+  let familyInfo : InductiveVal := {
+    name := familyDeclName
+    levelParams := familyLevelParams
+    type := familyRawType
+    numParams := hostNumParams
+    numIndices := 0
+    all := familyAll
+    ctors := [ctorName]
+    numNested := familyNumNested
+    isRec := false
+    isUnsafe := familyUnsafe
+    isReflexive := familyReflexive }
+  let constructorInfo : ConstructorVal := {
+    name := ctorDeclName
+    levelParams := ctorLevelParams
+    type := ctorRawType
+    induct := ctorInduct
+    cidx := ctorIndex
+    numParams := ctorNumParams
+    numFields := 0
+    isUnsafe := ctorUnsafe }
+  have hnonrec : c.env.isNonRecStructure familyName = true := by
+    unfold Kernel.Environment.isNonRecStructure
+    rw [hfamily]
+    rfl
+  obtain ⟨artifact⟩ := c.structureEtaReady.resolve familyName familyInfo ctorName
+    constructorInfo hfamily hctor hnonrec
+  have ⟨head', hstack⟩ := AppStack.build <|
+    normalizedType.mkAppList_getAppArgsList ▸ tTypeTr
+  have hheadTr := hstack.tr
+  rw [hhead] at hheadTr
+  let .const (us' := levels) hconst hlevelsMap hlevelsHostLength := hheadTr
+  have hviewFamily := artifact.projection.viewWF.family
+  rw [artifact.projection.name_eq] at hviewFamily
+  rw [hviewFamily] at hconst
+  cases hconst
+  have hlevelsWF : ∀ level ∈ levels,
+      level.WF c.lparams.length :=
+    VLevel.WF.of_mapM_ofLevel hlevelsMap
+  have hsourceUvars :
+      artifact.projection.view.generation.block.sourceType.uvars =
+        artifact.projection.view.uvars :=
+    artifact.projection.view.generation.block.sourceType_uvars_eq
+  have hlevelsLength : levels.length = artifact.projection.view.uvars :=
+    (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans
+      (hlevelsHostLength.trans hsourceUvars)
+  have hfamilyHead : c.HasType (.const familyName levels)
+      (artifact.projection.view.familyType.instL levels) :=
+    VEnv.HasType.const hviewFamily hlevelsWF
+      (hlevelsLength.trans hsourceUvars.symm)
+  obtain ⟨resultLevel, hrawResult⟩ := artifact.projection.rawResult_sort
+  let rawParams := artifact.projection.view.generation.block.rawParams.map
+    (VExpr.instL levels)
+  have hfamilyHeadShape : c.HasType (.const familyName levels)
+      (VExpr.forallN rawParams (.sort (resultLevel.inst levels))) := by
+    simpa [rawParams, VStructureView.familyType,
+      VInductDecl.NormalizedChecked.rawType_eq,
+      artifact.projection.view.raw_indices_eq, hrawResult,
+      VExpr.instL_forallN, VExpr.forallN, VExpr.instL] using hfamilyHead
+  have htTypeIsType : c.venv.IsType c.lparams.length c.vlctx.toCtx tType' :=
+    (aTyped.isType c.Ewf.ordered c.Δwf).defeqU_l c.Ewf c.Δwf
+      tTypeEq.symm
+  have normalizedTypeTr : c.TrExprS
+      (normalizedType.getAppFn.mkAppList normalizedType.getAppArgsList)
+      tType' := by
+    rw [normalizedType.mkAppList_getAppArgsList]
+    exact tTypeTr
+  obtain ⟨params, _hparamsTr, hparamsSpine, hfullTr⟩ :=
+    AppStack.toSpineWF_of_isType
+      (f := normalizedType.getAppFn)
+      (args := normalizedType.getAppArgsList)
+      (full' := tType') hstack hfamilyHeadShape
+      normalizedTypeTr htTypeIsType
+  have hparamsLength : params.length = artifact.projection.view.nparams :=
+    hparamsSpine.forallN_sort_length.trans <| by
+      simpa [rawParams] using
+        artifact.projection.view.generation.shape.1
+  have hfamilyShape : artifact.projection.view.familyType.instL levels =
+      VExpr.forallN rawParams (.sort (resultLevel.inst levels)) := by
+    simp [rawParams, VStructureView.familyType,
+      VInductDecl.NormalizedChecked.rawType_eq,
+      artifact.projection.view.raw_indices_eq, hrawResult,
+      VExpr.instL_forallN, VExpr.forallN, VExpr.instL]
+  have hparamsFamily : c.venv.SpineWF c.lparams.length c.vlctx.toCtx
+      (artifact.projection.view.familyType.instL levels) params
+      (.sort (resultLevel.inst levels)) := by
+    rw [hfamilyShape]
+    exact hparamsSpine
+  have hfullStruct : c.TrExprS normalizedType
+      (artifact.projection.view.structureType levels params) := by
+    rw [← normalizedType.mkAppList_getAppArgsList]
+    simpa [VStructureView.structureType,
+      artifact.projection.name_eq] using hfullTr
+  have hfullEq := hfullStruct.uniq c.Ewf (.refl c.Ewf c.Δwf) tTypeTr
+  have hstructTy₁ := VEnv.IsDefEqU.trans c.Ewf c.Δwf hfullEq tTypeEq
+  have hstructTy₂ := VEnv.IsDefEqU.trans c.Ewf c.Δwf hfullEq (h hb)
+  have haStruct := aTyped.defeqU_r c.Ewf c.Δwf hstructTy₁.symm
+  have hbStruct := bTyped.defeqU_r c.Ewf c.Δwf hstructTy₂.symm
+  have heta₁ := artifact.eta c.Δwf hlevelsWF hlevelsLength
+    hparamsLength ⟨_, hparamsFamily⟩ haStruct
+  have heta₂ := artifact.eta c.Δwf hlevelsWF hlevelsLength
+    hparamsLength ⟨_, hparamsFamily⟩ hbStruct
+  have hfieldsLength : artifact.projection.view.fields.length = 0 := by
+    calc
+      artifact.projection.view.fields.length =
+          artifact.projection.constructorInfo.numFields :=
+        artifact.projection.constructor_numFields_eq.symm
+      _ = constructorInfo.numFields :=
+        congrArg ConstructorVal.numFields artifact.constructor_info_eq
+      _ = 0 := rfl
+  have hfields : artifact.projection.view.fields = [] :=
+    List.length_eq_zero_iff.mp hfieldsLength
+  have hrebuild :
+      artifact.projection.view.etaRebuild levels params e₁' =
+        artifact.projection.view.etaRebuild levels params e₂' := by
+    simp [VStructureView.etaRebuild, VStructureView.projectionArgs,
+      VStructureView.specializedFields, hfields]
+  rw [hrebuild] at heta₁
+  exact VEnv.IsDefEqU.trans c.Ewf c.Δwf ⟨_, heta₁.symm⟩ ⟨_, heta₂⟩
+
 theorem isDefEqUnitLike.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
-    RecM.WF c s (isDefEqUnitLike e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := sorry
+    RecM.WF c s (isDefEqUnitLike e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' :=
+  isDefEqUnitLike.WF_of_structureEta he₁ he₂
 
 theorem isDefEqCore'.WF {c : VContext} {s : VState}
     (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') :
     RecM.WF c s (isDefEqCore' e₁ e₂) fun b _ => b = true → c.IsDefEqU e₁' e₂' := by
-  unfold isDefEqCore'; extract_lets F1 F2 F3
+  unfold isDefEqCore'; extract_lets F1
   refine (quickIsDefEq.WF he₁ he₂).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun hb => h (by simpa using hb); skip]
-  refine .pureBind <| .readThe ?_
-  suffices ∀ {s}, RecM.WF c s (F2 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
+  refine .readThe ?_
+  suffices ∀ {s}, RecM.WF c s (F1 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
     split <;> [rename_i h1; exact this]
     refine (whnf.WF he₁).bind fun _ _ _ ⟨_, _, a1, a2⟩ => ?_
     split <;> [rename_i h2; exact this]
@@ -501,29 +1159,29 @@ theorem isDefEqCore'.WF {c : VContext} {s : VState}
     cases c.hasPrimitives.boolTrue c1
     simp at b3 c3; subst b3 c3; simp at b2 c2; subst b2 c2
     exact a2.symm
-  intro; unfold F2
+  intro; unfold F1
   refine (whnfCore.WF he₁).bind fun _ _ _ ⟨_, e₁', a1, a2⟩ => ?_
   refine (whnfCore.WF he₂).bind fun _ _ _ ⟨_, e₂', b1, b2⟩ => ?_
-  extract_lets F2 F3
+  extract_lets F2
   refine .mono (Q := fun b _ => b = true → c.IsDefEqU e₁' e₂') ?_ fun _ _ _ h hb =>
     a2.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf b2
-  suffices ∀ {s}, RecM.WF c s (F3 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
+  suffices ∀ {s}, RecM.WF c s (F2 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
     split <;> [skip; exact this]
     refine (quickIsDefEq.WF a1 b1).bind fun _ _ _ h => ?_
     split <;> [skip; exact this]
     exact .pure fun hb => h (by simpa using hb)
-  intro; unfold F3
+  intro; unfold F2
   refine (isDefEqProofIrrel.WF a1 b1).bind fun _ _ _ h => ?_
   split
   · exact .pure fun hb => h (by simpa using hb)
-  refine .pureBind <| (lazyDeltaReduction.loop.WF a1 b1).readThe.bind fun _ _ _ h => ?_; split
+  refine (lazyDeltaReduction.loop.WF a1 b1).readThe.bind fun _ _ _ h => ?_; split
   · cases h.1
   · exact .pure h
   have ⟨⟨e₁', c1, c4⟩, ⟨e₂', d1, d4⟩⟩ := h
   refine .mono (Q := fun b _ => b = true → c.IsDefEqU e₁' e₂') ?_ fun _ _ _ h hb =>
     c4.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf d4
-  extract_lets F2 F3 F4 F5 F6 F7
-  suffices ∀ {s}, RecM.WF c s (F7 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
+  extract_lets F3
+  suffices ∀ {s}, RecM.WF c s (F3 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by
     split
     · split <;> [rename_i h2; exact this]
       refine .pure fun _ => ?_
@@ -545,20 +1203,20 @@ theorem isDefEqCore'.WF {c : VContext} {s : VState}
       simp at h2; subst h2; clear h
       exact .pure fun _ => c2.uniq c.Ewf (.refl c.Δwf) d2 (h ‹_›)
     · exact this
-  intro; unfold F7
+  intro; unfold F3
   refine (whnfCore.WF c1).bind fun _ _ _ ⟨_, e₁'', c5, c6⟩ => ?_
   refine (whnfCore.WF d1).bind fun _ _ _ ⟨_, e₂'', d5, d6⟩ => ?_
   split
-  · exact (isDefEqCore.WF c5 d5).bind fun _ _ _ h => .pure fun hb =>
+  · exact (isDefEqCore.WF c5 d5).mono fun _ _ _ h hb =>
       c6.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf d6
-  refine .pureBind <| (isDefEqApp.WF c1 d1).bind fun _ _ _ h => ?_
+  refine (isDefEqApp.WF c1 d1).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun _ => h ‹_›; skip]
-  refine .pureBind <| (tryEtaExpansion.WF c1 d1).bind fun _ _ _ h => ?_
+  refine (tryEtaExpansion.WF c1 d1).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun _ => h ‹_›; skip]
-  refine .pureBind <| (tryEtaStruct.WF c1 d1).bind fun _ _ _ h => ?_
+  refine (tryEtaStruct.WF c1 d1).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun _ => h ‹_›; skip]
-  refine .pureBind <| (tryStringLitExpansion.WF c1 d1).bind fun _ _ _ h => ?_
+  refine (tryStringLitExpansion.WF c1 d1).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun hb => h (by simpa using hb); skip]
-  refine .pureBind <| (isDefEqUnitLike.WF c1 d1).bind fun _ _ _ h => ?_
+  refine (isDefEqUnitLike.WF c1 d1).bind fun _ _ _ h => ?_
   split <;> [exact .pure fun _ => h ‹_›; skip]
-  exact .pureBind <| .pure nofun
+  exact .pure nofun
diff --git a/Lean4Lean/Verify/TypeChecker/Reduce.lean b/Lean4Lean/Verify/TypeChecker/Reduce.lean
index 49d9799d..f8a14781 100644
--- a/Lean4Lean/Verify/TypeChecker/Reduce.lean
+++ b/Lean4Lean/Verify/TypeChecker/Reduce.lean
@@ -94,23 +94,9 @@ theorem reduceNat.WF {c : VContext} (he : c.TrExprS e e') :
   replace hprims {a} : Environment.primitives.contains a ↔ a ∈ prims := by
     simp [hprims, NameSet.contains, NameSet.ofList]
   unfold reduceNat; extract_lets nargs F1 fn
-  split <;> (split <;> [skip; exact hP ▸ .pure nofun])
-  · rename_i h1 h2
-    simp [nargs, Expr.getAppNumArgs_eq] at h1; subst fn
-    let .app f a := e; simp [Expr.appFn!, Expr.structuralEq_const] at h2 ⊢; subst h2
-    let .app ha1 ha2 hf ha := he
-    let .const h1 h2 h3 := hf
-    refine (whnf.WF ha).bind fun a₁ _ _ ⟨a1, _, a2, a3⟩ => ?_
-    split <;> [rename_i n h; exact hP ▸ .pure nofun]
-    obtain ⟨hn, rfl⟩ := rawNatLitExt?.WF h a2
-    refine hP ▸ .pure ?_; rintro _ ⟨⟩; refine ⟨fun _ _ _ => trivial, ?_⟩
-    have ⟨ci, c1, _⟩ := c.trenv.find?_iff.2 ⟨_, h1⟩
-    have ⟨c2, c3⟩ := c.safePrimitives c1 <| hprims.2 (by simp [prims])
-    have ⟨d1, d2, d3⟩ := c.trenv.find?_uniq c1 h1; cases h2
-    refine have ⟨p1, p2⟩ := TrExprS.natLit c.hasPrimitives hn _; ⟨_, p1, ?_⟩
-    refine p2.toU.symm.trans c.Ewf c.Δwf ?_
-    exact ⟨_, ha1.appDF <| a3.of_r c.Ewf c.Δwf ha2⟩
-  · split <;> [rename_i f ls a b _ h2; exact hP ▸ .pure nofun]
+  cases h1 : nargs == 1 <;> simp only [Bool.false_eq_true, ↓reduceIte]
+  · cases nargs == 2 <;> [exact hP ▸ .pure nofun; simp only [↓reduceIte]]
+    split <;> [rename_i f ls a b; exact hP ▸ .pure nofun]
     have hfun guard {g fc G} [DecidableRel guard] (hprim : fc ∈ prims)
         (heval : c.venv.ReflectsNatNatNat fc g) (hG : RecM.WF c s G P) :
         RecM.WF c s (do if f == fc then {return ← reduceBinNatOpG guard g a b}; G) P := by
@@ -138,3 +124,18 @@ theorem reduceNat.WF {c : VContext} (he : c.TrExprS e e') :
     apply hfun (fun _ _ => False) (by simp [prims]) c.hasPrimitives.natShiftLeft
     apply hfun (fun _ _ => False) (by simp [prims]) c.hasPrimitives.natShiftRight
     exact hP ▸ .pure nofun
+  · split <;> [rename_i h2; exact hP ▸ .pure nofun]
+    simp [nargs, Expr.getAppNumArgs_eq] at h1; subst fn
+    let .app f a := e; simp [Expr.appFn!, Expr.structuralEq_const] at h2 ⊢; subst h2
+    let .app ha1 ha2 hf ha := he
+    let .const h1 h2 h3 := hf
+    refine (whnf.WF ha).bind fun a₁ _ _ ⟨a1, _, a2, a3⟩ => ?_
+    split <;> [rename_i n h; exact hP ▸ .pure nofun]
+    obtain ⟨hn, rfl⟩ := rawNatLitExt?.WF h a2
+    refine hP ▸ .pure ?_; rintro _ ⟨⟩; refine ⟨fun _ _ _ => trivial, ?_⟩
+    have ⟨ci, c1, _⟩ := c.trenv.find?_iff.2 ⟨_, h1⟩
+    have ⟨c2, c3⟩ := c.safePrimitives c1 <| hprims.2 (by simp [prims])
+    have ⟨d1, d2, d3⟩ := c.trenv.find?_uniq c1 h1; cases h2
+    refine have ⟨p1, p2⟩ := TrExprS.natLit c.hasPrimitives hn _; ⟨_, p1, ?_⟩
+    refine p2.toU.symm.trans c.Ewf c.Δwf ?_
+    exact ⟨_, ha1.appDF <| a3.of_r c.Ewf c.Δwf ha2⟩
diff --git a/Lean4Lean/Verify/TypeChecker/WHNF.lean b/Lean4Lean/Verify/TypeChecker/WHNF.lean
index 9815dcdf..e009e02c 100644
--- a/Lean4Lean/Verify/TypeChecker/WHNF.lean
+++ b/Lean4Lean/Verify/TypeChecker/WHNF.lean
@@ -4,11 +4,11 @@ namespace Lean4Lean.TypeChecker.Inner
 open Lean hiding Environment Exception
 
 theorem reduceRecursor.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
-    RecM.WF c s (reduceRecursor e cheapRec cheapProj) fun oe _ =>
+    RecM.WF c s (reduceRecursor e) fun oe _ =>
       ∀ e₁, oe = some e₁ → c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := sorry
 
 theorem whnfFVar.WF {c : VContext} {s : VState} (he : c.TrExprS (.fvar fv) e') :
-    RecM.WF c s (whnfFVar (.fvar fv) cheapRec cheapProj) fun e₁ _ =>
+    RecM.WF c s (whnfFVar (.fvar fv) cheapProj) fun e₁ _ =>
       c.FVarsBelow (.fvar fv) e₁ ∧ c.TrExpr e₁ e' := by
   refine .getLCtx ?_
   simp [Expr.fvarId!]; split <;> [skip; exact .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩]
@@ -23,30 +23,126 @@ theorem whnfFVar.WF {c : VContext} {s : VState} (he : c.TrExprS (.fvar fv) e') :
   exact .refl c.Ewf c.Δwf
 
 theorem reduceProj.WF {c : VContext} {s : VState} (he : c.TrExprS (.proj n i e) e') :
-    RecM.WF c s (reduceProj i e cheapRec cheapProj) fun oe _ =>
-      ∀ e₁, oe = some e₁ → c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e' := sorry
+    RecM.WF c s (reduceProj i e cheapProj) fun oe _ =>
+      ∀ e₁, oe = some e₁ → c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e' := by
+  let .proj (e' := major) heMajor hproj := he
+  obtain ⟨view, levels, params, _hviewName, hsemantic⟩ := hproj
+  obtain ⟨code, hcode, hresult, hprojector⟩ := hsemantic.program
+  have finish {normal : Expr} {state : VState}
+      (hbelow : c.FVarsBelow e normal)
+      (htr : c.TrExpr normal major) :
+      RecM.WF c state
+        (normal.withApp fun mk args => do
+          let .const mkC _ := mk | return none
+          let env ← getEnv
+          let .ctorInfo mkInfo ← env.get mkC | return none
+          return args[mkInfo.numParams + i]?) (fun oe _ =>
+            ∀ e₁, oe = some e₁ →
+              c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e') := by
+    rw [Expr.withApp_eq]
+    split
+    · rename_i mkC hostLevels hheadShape
+      obtain ⟨runtimeMajor, hnormalS, hnormalEq⟩ := htr
+      have ⟨runtimeHead, hstack⟩ := AppStack.build
+        (normal.mkAppList_getAppArgsList ▸ hnormalS)
+      have hhead := hstack.tr
+      rw [hheadShape] at hhead
+      let .const (us' := runtimeLevels) _hconst _hlevelsMap
+          _hlevelsLength := hhead
+      obtain ⟨runtimeArgs, hargsTr, hfull⟩ := hstack.argsTranslation
+      rw [normal.mkAppList_getAppArgsList] at hfull
+      have hfullEq := hfull.uniq c.Ewf (.refl c.Ewf c.Δwf) hnormalS
+      have hmajorEq := hfullEq.trans c.Ewf c.Δwf hnormalEq
+      refine .getEnv ?_
+      refine (M.WF.liftExcept envGet.WF).lift.bind fun _ci _ _ hfind => ?_
+      split
+      · rename_i mkInfo
+        refine .pure ?_
+        intro selected hselected
+        have hconstructorName : mkC = view.constructorName :=
+          c.Ewf.registeredStructureHeadInversion.constructor_name_inv
+            c.Δwf hsemantic rfl hmajorEq
+        have hnumParams : mkInfo.numParams = view.nparams :=
+          c.projectionReady.constructorNumParams view mkInfo
+            hsemantic.viewWF (by
+              rw [← hconstructorName]
+              exact hfind)
+        have hselectedList :
+            normal.getAppArgsList[mkInfo.numParams + i]? = some selected := by
+          rw [← Expr.getAppArgs_toList, Array.getElem?_toList]
+          exact hselected
+        obtain ⟨runtimeField, hfieldGet, hfieldTr⟩ :=
+          Lean4Lean.List.Forall₂.getElem?_left hargsTr hselectedList
+        have hfieldGetCanonical :
+            runtimeArgs[view.nparams + i]? = some runtimeField := by
+          rw [← hnumParams]
+          exact hfieldGet
+        obtain ⟨alignment⟩ :=
+          c.Ewf.registeredStructureHeadInversion.constructor_inv
+            c.Δwf hsemantic hcode rfl hfieldGetCanonical hmajorEq
+        have hiota := hsemantic.projector_constructor_aligned
+          c.Ewf c.Δwf hcode hprojector alignment
+        have hmajorTyped := hmajorEq.of_r c.Ewf c.Δwf hsemantic.majorType
+        have hprojectorCongr : c.IsDefEqU
+            (.app code.projector
+              (VExpr.appN (.const mkC runtimeLevels) runtimeArgs))
+            (.app code.projector major) :=
+          ⟨_, hprojector.appDF hmajorTyped⟩
+        have hfieldTarget : c.IsDefEqU runtimeField e' := by
+          rw [hresult]
+          exact hiota.symm.trans c.Ewf c.Δwf hprojectorCongr
+        refine ⟨?_, ⟨runtimeField, hfieldTr, hfieldTarget⟩⟩
+        intro P hP hprojFv
+        exact FVarsIn.getAppArgsList (hbelow P hP hprojFv)
+          (List.mem_of_getElem? hselectedList)
+      · exact .pure nofun
+    · exact .pure nofun
+  unfold reduceProj
+  split
+  · refine (whnfCore.WF heMajor).bind fun normal _ _ hnormal => ?_
+    split
+    · obtain ⟨literalMajor, hliteralS, hliteralEq⟩ := hnormal.2
+      let .lit _ hconstructorS := hliteralS
+      refine (whnf.WF hconstructorS).bind fun expanded _ _ hexpanded => ?_
+      have hbelow' : c.FVarsBelow e expanded :=
+        FVarsBelow.trans (fun _ _ _ => FVarsIn.strLitToConstructor)
+          hexpanded.1
+      have htr' := hexpanded.2.defeq c.Ewf c.Δwf hliteralEq
+      exact RecM.WF.pureBind (finish hbelow' htr')
+    · exact RecM.WF.pureBind (finish hnormal.1 hnormal.2)
+  · refine (whnf.WF heMajor).bind fun normal _ _ hnormal => ?_
+    split
+    · obtain ⟨literalMajor, hliteralS, hliteralEq⟩ := hnormal.2
+      let .lit _ hconstructorS := hliteralS
+      refine (whnf.WF hconstructorS).bind fun expanded _ _ hexpanded => ?_
+      have hbelow' : c.FVarsBelow e expanded :=
+        FVarsBelow.trans (fun _ _ _ => FVarsIn.strLitToConstructor)
+          hexpanded.1
+      have htr' := hexpanded.2.defeq c.Ewf c.Δwf hliteralEq
+      exact RecM.WF.pureBind (finish hbelow' htr')
+    · exact RecM.WF.pureBind (finish hnormal.1 hnormal.2)
 
 theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
-    RecM.WF c s (whnfCore' e cheapRec cheapProj) fun e₁ _ =>
+    RecM.WF c s (whnfCore' e cheapProj) fun e₁ _ =>
       c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by
-  unfold whnfCore'; extract_lets F G
+  unfold whnfCore'; extract_lets F
   let full := (· matches Expr.fvar _ | .app .. | .letE .. | .proj ..)
   generalize hP : (fun e₁ (_ : VState) => _) = P
   have hid {s} : RecM.WF c s (pure e) P := hP ▸ .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩
-  suffices hG : full e → RecM.WF c s (G ⟨⟩) P by
+  suffices hF : full e → RecM.WF c s (F ⟨⟩) P by
     split
     any_goals exact hid
-    any_goals exact hG rfl
+    any_goals exact hF rfl
     · let .mdata he := he
-      exact (whnfCore'.WF he).bind fun _ _ _ h => hP ▸ .pure h
-    · refine .getLCtx ?_; split <;> [exact hid; exact hG rfl]
-  simp [G]; refine fun hfull => .get ?_; split
+      exact hP ▸ whnfCore'.WF he
+    · refine .getLCtx ?_; split <;> [exact hid; exact hF rfl]
+  simp [F]; refine fun hfull => .get ?_; split
   · rename_i r eq; refine .stateWF fun wf => hP ▸ .pure ?_
     have ⟨_, h1, h2, h3⟩ := (wf.whnfCore_wf eq).2.2.2.2 he.fvarsIn
     refine ⟨h1, h3.defeq c.Ewf c.Δwf ?_⟩
     exact h2.uniq c.Ewf (.refl c.Ewf c.Δwf) he
   have hsave {e₁ s} (h1 : c.FVarsBelow e e₁) (h2 : c.TrExpr e₁ e') :
-      (save e cheapRec cheapProj e₁).WF c s P := by
+      (save e cheapProj e₁).WF c s P := by
     simp [save]
     split <;> [skip; exact hP ▸ .pure ⟨h1, h2⟩]
     rintro _ mwf wf a s' ⟨⟩
@@ -59,16 +155,15 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
       · exact he.fvarsIn.mono wf.ngen_wf
       · exact h2.fvarsIn.mono wf.ngen_wf
     exact hP ▸ ⟨.rfl, { wf with whnfCore_wf := hic wf.whnfCore_wf }, h1, h2⟩
-  unfold F; split <;> cases hfull
-  · simp; exact hP ▸ whnfFVar.WF he
+  split <;> cases hfull
+  · exact hP ▸ whnfFVar.WF he
   · rename_i fn arg _; generalize eq : fn.app arg = e at *
-    rw [Expr.withRevApp_eq]
     have ⟨_, stk⟩ := AppStack.build <| e.mkAppList_getAppArgsList ▸ he
     refine (whnfCore.WF stk.tr).bind fun _ s _ ⟨h1, h2⟩ => ?_
     split <;> [rename_i name dom body bi _; split]
     · let rec loop.WF {e e' i rargs f} (H : LambdaBodyN i e' f) (hi : i ≤ rargs.size) :
         ∃ n f', LambdaBodyN n e' f' ∧ n ≤ rargs.size ∧
-          loop e cheapRec cheapProj rargs i f = loop.cont e cheapRec cheapProj rargs n f' := by
+          loop e cheapProj rargs i f = loop.cont e cheapProj rargs n f' := by
         unfold loop; split
         · split
           · refine loop.WF (by simpa [Nat.add_comm] using H.add (.succ .zero)) ‹_›
@@ -120,7 +215,7 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
       let ⟨h3, _, h4, eq⟩ := eq ▸ this h1 (eq ▸ he) stk.tr h2
       refine (whnfCore.WF h4).bind fun _ _ _ ⟨h5, h6⟩ => ?_
       refine hsave (h3.trans h5) (h6.defeq c.Ewf c.Δwf eq)
-  · let .letE h1 h2 h3 h4 := he; simp
+  · let .letE h1 h2 h3 h4 := he
     refine (whnfCore.WF (h4.inst_let c.Ewf.ordered h3)).bind fun _ _ _ ⟨h1, h2⟩ => ?_
     exact hsave (.trans (fun _ _ he => he.2.2.instantiate1 he.2.1) h1) h2
   · refine (reduceProj.WF he).bind fun _ _ _ H => ?_
@@ -132,32 +227,29 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
 
 theorem whnf'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') :
     RecM.WF c s (whnf' e) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by
-  unfold whnf'; extract_lets F G
+  unfold whnf'; extract_lets F
   generalize hP : (fun e₁ (_ : VState) => _) = P
   have hid {s} : RecM.WF c s (pure e) P := hP ▸ .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩
-  suffices hG : RecM.WF c s (G ()) P by
+  suffices hF : RecM.WF c s (F ()) P by
     split
     any_goals exact hid
-    any_goals exact hG
+    any_goals exact hF
     · let .mdata he := he
-      exact (whnf'.WF he).bind fun _ _ _ h => hP ▸ .pure h
-    · refine .getLCtx ?_; split <;> [exact hid; exact hG]
-  simp [G]; refine .get ?_; split
+      exact hP ▸ whnf'.WF he
+    · refine .getLCtx ?_; split <;> [exact hid; exact hF]
+  simp [F]; refine .get ?_; split
   · rename_i r eq; refine .stateWF fun wf => hP ▸ .pure ?_
     have ⟨_, h1, h2, h3⟩ := (wf.whnf_wf eq).2.2.2.2 he.fvarsIn
     refine ⟨h1, h3.defeq c.Ewf c.Δwf ?_⟩
     exact h2.uniq c.Ewf (.refl c.Ewf c.Δwf) he
-  unfold F
   have {e e' s n} (he : c.TrExprS e e') : (loop e n).WF c s fun e₁ _ =>
       c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by
     induction n generalizing s e e' with | zero => exact .throw | succ n ih => ?_
     refine .getEnv <| (whnfCore'.WF he).bind fun e₁ s _ ⟨h1, _, he₁, eq⟩ => ?_
     refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h3 => ?_
-    extract_lets F1 F2; split <;> [cases h3 _ rfl; skip]
-    refine .pureBind ?_; unfold F2
+    split <;> [cases h3 _ rfl; skip]
     refine (reduceNat.WF he₁).bind fun _ _ _ h3 => ?_; split
     · exact .pure ⟨.trans h1 (h3 _ rfl).1, (h3 _ rfl).2.defeq c.Ewf c.Δwf eq⟩
-    refine .pureBind ?_; unfold F1
     refine (unfoldDefinition.WF he₁).bind fun _ _ _ H => ?_
     split <;> [skip; exact .pure ⟨h1, _, he₁, eq⟩]
     have ⟨a1, _, a2, eq'⟩ := H
diff --git a/Lean4Lean/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean
index a572fabd..1667a41f 100644
--- a/Lean4Lean/Verify/Typing/Expr.lean
+++ b/Lean4Lean/Verify/Typing/Expr.lean
@@ -1,4 +1,6 @@
 import Lean4Lean.Theory.Typing.Basic
+import Lean4Lean.Theory.Literals
+import Lean4Lean.Theory.Projection
 import Lean4Lean.Verify.NameGenerator
 import Lean4Lean.Verify.VLCtx
 import Lean4Lean.Verify.Axioms
@@ -44,10 +46,6 @@ def FVarsIn : Expr → Prop
 
 nonrec abbrev _root_.Lean.Expr.FVarsIn := @FVarsIn
 
-def VLocalDecl.WF (env : VEnv) (U : Nat) (Γ : List VExpr) : VLocalDecl → Prop
-  | .vlam type => env.IsType U Γ type
-  | .vlet type value => env.HasType U Γ value type
-
 def VLCtx.FVWF : VLCtx → Prop
   | [] => True
   | (ofv, _) :: (Δ : VLCtx) =>
@@ -60,15 +58,19 @@ def VLCtx.WF : VLCtx → Prop
     VLCtx.WF Δ ∧ (∀ fv deps, ofv = some (fv, deps) → fv ∉ Δ.fvars ∧ deps ⊆ Δ.fvars) ∧
     VLocalDecl.WF env U Δ.toCtx d
 
-def VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF
+theorem VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF
   | [], h => h
   | _ :: _, ⟨h1, h2, _⟩ => ⟨h1.fvwf, h2⟩
 
-def TrProj : ∀ (Γ : List VExpr) (structName : Name) (idx : Nat) (e : VExpr), VExpr → Prop := sorry
-
-def VEnv.ContainsLits (env : VEnv) : Literal → Prop
-  | .natVal _ => env.contains ``Nat
-  | .strVal _ => env.contains ``Char.ofNat ∧ env.contains ``String.ofList
+/-- Verify compatibility surface for Theory's environment-indexed projection
+semantics.  The view, universe instantiation, and parameter spine are hidden
+from existing expression-translation consumers, but each witness is fully
+constrained by `VEnv.TrProj`; no metadata is existentially invented. -/
+def TrProj (env : VEnv) (U : Nat) (Γ : List VExpr)
+    (structName : Name) (idx : Nat) (e result : VExpr) : Prop :=
+  ∃ view levels params,
+    view.name = structName ∧
+      env.TrProj U Γ view levels params idx e result
 
 variable (env : VEnv) (Us : List Name) in
 inductive TrExprS : VLCtx → Expr → VExpr → Prop
@@ -100,73 +102,37 @@ inductive TrExprS : VLCtx → Expr → VExpr → Prop
     TrExprS Δ (.letE name ty val body nd) body'
   | lit : env.ContainsLits l → TrExprS Δ l.toConstructor e → TrExprS Δ (.lit l) e
   | mdata : TrExprS Δ e e' → TrExprS Δ (.mdata d e) e'
-  | proj : TrExprS Δ e e' → TrProj Δ.toCtx s i e' e'' → TrExprS Δ (.proj s i e) e''
+  | proj : TrExprS Δ e e' →
+    TrProj env Us.length Δ.toCtx s i e' e'' →
+    TrExprS Δ (.proj s i e) e''
 
 def TrExpr (env : VEnv) (Us : List Name) (Δ : VLCtx) (e : Expr) (e' : VExpr) : Prop :=
   ∃ e₂, TrExprS env Us Δ e e₂ ∧ env.IsDefEqU Us.length Δ.toCtx e₂ e'
 
-def VExpr.bool : VExpr := .const ``Bool []
-def VExpr.boolTrue : VExpr := .const ``Bool.true []
-def VExpr.boolFalse : VExpr := .const ``Bool.false []
-def VExpr.boolLit : Bool → VExpr
-  | .false => .boolFalse
-  | .true => .boolTrue
-
-def VExpr.nat : VExpr := .const ``Nat []
-def VExpr.natZero : VExpr := .const ``Nat.zero []
-def VExpr.natSucc : VExpr := .const ``Nat.succ []
-def VExpr.natLit : Nat → VExpr
-  | 0 => .natZero
-  | n+1 => .app .natSucc (.natLit n)
-
-def VExpr.char : VExpr := .const ``Char []
-def VExpr.string : VExpr := .const ``String []
-def VExpr.stringOfList : VExpr := .const ``String.ofList []
-def VExpr.listChar : VExpr := .app (.const ``List [.zero]) .char
-def VExpr.listCharNil : VExpr := .app (.const ``List.nil [.zero]) .char
-def VExpr.listCharCons : VExpr := .app (.const ``List.cons [.zero]) .char
-def VExpr.charOfNat : VExpr := .const ``Char.ofNat []
-def VExpr.listCharLit : List Char → VExpr
-  | [] => .listCharNil
-  | a :: as => .app (.app .listCharCons (.app .charOfNat (.natLit a.toNat))) (.listCharLit as)
-
-def VExpr.trLiteral : Literal → VExpr
-  | .natVal n => .natLit n
-  | .strVal s => .app .stringOfList (.listCharLit s.toList)
-
-def VEnv.ReflectsNatNatNat (env : VEnv) (fc : Name) (f : Nat → Nat → Nat) :=
-  env.contains fc →
-  ∀ a b, env.IsDefEqU 0 [] (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.natLit (f a b))
-
-def VEnv.ReflectsNatNatBool (env : VEnv) (fc : Name) (f : Nat → Nat → Bool) :=
-  env.contains fc →
-  ∀ a b, env.IsDefEqU 0 [] (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.boolLit (f a b))
-
-structure VEnv.HasPrimitives (env : VEnv) : Prop where
-  bool : env.contains ``Bool → env.contains ``Bool.false ∧ env.contains ``Bool.true
-  boolFalse : env.constants ``Bool.false = some ci → ci = { uvars := 0, type := .bool }
-  boolTrue : env.constants ``Bool.true = some ci → ci = { uvars := 0, type := .bool }
-  nat : env.contains ``Nat → env.contains ``Nat.zero ∧ env.contains ``Nat.succ
-  natZero : env.constants ``Nat.zero = some ci → ci = { uvars := 0, type := .nat }
-  natSucc : env.constants ``Nat.succ = some ci →
-    ci = { uvars := 0, type := .forallE .nat .nat }
-  natAdd : env.ReflectsNatNatNat ``Nat.add Nat.add
-  natSub : env.ReflectsNatNatNat ``Nat.sub Nat.sub
-  natMul : env.ReflectsNatNatNat ``Nat.mul Nat.mul
-  natPow : env.ReflectsNatNatNat ``Nat.pow Nat.pow
-  natGcd : env.ReflectsNatNatNat ``Nat.gcd Nat.gcd
-  natMod : env.ReflectsNatNatNat ``Nat.mod Nat.mod
-  natDiv : env.ReflectsNatNatNat ``Nat.div Nat.div
-  natBEq : env.ReflectsNatNatBool ``Nat.beq Nat.beq
-  natBLE : env.ReflectsNatNatBool ``Nat.ble Nat.ble
-  natLAnd : env.ReflectsNatNatNat ``Nat.land Nat.land
-  natLOr : env.ReflectsNatNatNat ``Nat.lor Nat.lor
-  natXor : env.ReflectsNatNatNat ``Nat.xor Nat.xor
-  natShiftLeft : env.ReflectsNatNatNat ``Nat.shiftLeft Nat.shiftLeft
-  natShiftRight : env.ReflectsNatNatNat ``Nat.shiftRight Nat.shiftRight
-  charOfNat : env.constants ``Char.ofNat = some ci →
-    ci = { uvars := 0, type := .forallE .nat .char }
-  stringOfList : env.constants ``String.ofList = some ci →
-    ci = { uvars := 0, type := .forallE .listChar .string } ∧
-    env.HasType 0 [] .listCharNil .listChar ∧
-    env.HasType 0 [] .listCharCons (.forallE .char <| .forallE .listChar .listChar)
+/-- Deterministic shadow of `TrExprS`: compute the strict Theory translation
+of an expression syntactically.  Every semantic premise of `TrExprS` only
+validates a translation, it never selects between candidates, so on the
+`TrExprS.IsUnique` fragment this function returns exactly the translation of
+any derivation (`TrExprS.trExprS?_eq`).  The function checks nothing
+semantic: it is meaningful only through that agreement theorem.  The pushed
+`vlet` type is a dummy because `TrExprS` never reads it — `VLCtx.find?`
+returns a let's value, and the type component is existentially discarded. -/
+def trExprS? (Us : List Name) : VLCtx → Expr → Option VExpr
+  | Δ, .bvar i => (Δ.find? (.inl i)).map (·.1)
+  | Δ, .fvar fv => (Δ.find? (.inr fv)).map (·.1)
+  | _, .sort u => (VLevel.ofLevel Us u).map .sort
+  | _, .const c us => (us.mapM (VLevel.ofLevel Us)).map (VExpr.const c)
+  | Δ, .app f a => do return .app (← trExprS? Us Δ f) (← trExprS? Us Δ a)
+  | Δ, .lam _ ty body _ => do
+      let ty' ← trExprS? Us Δ ty
+      return .lam ty' (← trExprS? Us ((none, .vlam ty') :: Δ) body)
+  | Δ, .forallE _ ty body _ => do
+      let ty' ← trExprS? Us Δ ty
+      return .forallE ty' (← trExprS? Us ((none, .vlam ty') :: Δ) body)
+  | Δ, .letE _ _ val body _ => do
+      let val' ← trExprS? Us Δ val
+      trExprS? Us ((none, .vlet (.sort .zero) val') :: Δ) body
+  | _, .lit l => some (.trLiteral l)
+  | Δ, .mdata _ e => trExprS? Us Δ e
+  | _, .proj .. => none
+  | _, .mvar .. => none
diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean
index 11f51804..e6a5dc5e 100644
--- a/Lean4Lean/Verify/Typing/Lemmas.lean
+++ b/Lean4Lean/Verify/Typing/Lemmas.lean
@@ -136,6 +136,17 @@ theorem Closed.getAppArgsList {e} (h : Closed e)
     {{a}} (ha : a ∈ e.getAppArgsList) : Closed a :=
   h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse])
 
+theorem FVarsIn.getAppArgsRevList {e} (h : FVarsIn P e)
+    {{a}} (ha : a ∈ e.getAppArgsRevList) : FVarsIn P a := by
+  revert a
+  unfold Expr.getAppArgsRevList
+  split <;> simp
+  exact ⟨h.2, FVarsIn.getAppArgsRevList h.1⟩
+
+theorem FVarsIn.getAppArgsList {e} (h : FVarsIn P e)
+    {{a}} (ha : a ∈ e.getAppArgsList) : FVarsIn P a :=
+  h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse])
+
 theorem Closed.looseBVarRange_le : Closed e k → e.looseBVarRange' ≤ k := by
   induction e generalizing k <;>
     simp +contextual [*, Closed, Expr.looseBVarRange', Nat.max_le]
@@ -144,57 +155,16 @@ theorem Closed.looseBVarRange_le : Closed e k → e.looseBVarRange' ≤ k := by
 theorem Closed.looseBVarRange_zero (H : Closed e) : e.looseBVarRange' = 0 := by
   simpa using H.looseBVarRange_le
 
-theorem VLocalDecl.lift'_consN_skipN {d : VLocalDecl} :
-    d.lift' (.consN (.skipN .refl n) k) = d.liftN n k := by
-  cases d <;> simp [VLocalDecl.lift', VLocalDecl.liftN, VExpr.lift'_consN_skipN]
-
 theorem VLocalDecl.WF.hasType : ∀ {d}, VLocalDecl.WF env U (VLCtx.toCtx Δ) d →
     env.HasType U (VLCtx.toCtx ((ofv, d) :: Δ)) d.value d.type
   | .vlam _, _ => .bvar .zero
   | .vlet .., hA => hA
 
-nonrec theorem VLocalDecl.WF.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') :
-    ∀ {d}, WF env U Γ d → WF env U Γ' (d.liftN n k)
-  | .vlam _,  H | .vlet .., H => H.weakN henv W
-
-nonrec theorem VLocalDecl.WF.instN (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
-    (h₀ : env.HasType U Γ₀ e₀ A₀) : ∀ {d}, WF env U Γ₁ d → WF env U Γ (d.inst e₀ k)
-  | .vlam _,  H | .vlet .., H => H.instN henv W h₀
-
-nonrec theorem VLocalDecl.WF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') :
-    ∀ {d}, WF env ls.length Γ d → WF env U' (Γ.map (·.instL ls)) (d.instL ls)
-  | .vlam _,  H | .vlet .., H => H.instL hls
-
 theorem VLocalDecl.is_liftN {Δ : VLCtx} :
     ∀ {d}, Ctx.LiftN (VLocalDecl.depth d) 0 Δ.toCtx (VLCtx.toCtx ((ofv, d) :: Δ))
   | .vlam _ => .one
   | .vlet .. => .zero []
 
-variable! (env : VEnv) (U : Nat) (Γ : List VExpr) in
-inductive VLocalDecl.IsDefEq : VLocalDecl → VLocalDecl → Prop
-  | vlam : env.IsDefEq U Γ type₁ type₂ (.sort u) → VLocalDecl.IsDefEq (.vlam type₁) (.vlam type₂)
-  | vlet :
-    env.IsDefEq U Γ value₁ value₂ type₁ → env.IsDefEq U Γ type₁ type₂ (.sort u) →
-    VLocalDecl.IsDefEq (.vlet type₁ value₁) (.vlet type₂ value₂)
-
-@[simp] theorem VLocalDecl.lift'_depth {d : VLocalDecl} : (d.lift' n).depth = d.depth := by
-  cases d <;> rfl
-
-theorem VLocalDecl.lift'_comp {d : VLocalDecl} : d.lift' (.comp l₁ l₂) = (d.lift' l₁).lift' l₂ := by
-  cases d <;> simp [VLocalDecl.lift', VExpr.lift'_comp]
-
-variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) (W : Ctx.Lift' n Γ Γ') in
-theorem VLocalDecl.weak'_iff : VLocalDecl.WF env U Γ' (d.lift' n) ↔ VLocalDecl.WF env U Γ d :=
-  match d with
-  | .vlam .. => IsType.weak'_iff henv hΓ' W
-  | .vlet .. => HasType.weak'_iff henv hΓ' W
-
-variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) (W : Ctx.LiftN n k Γ Γ') in
-theorem VLocalDecl.weakN_iff : VLocalDecl.WF env U Γ' (d.liftN n k) ↔ VLocalDecl.WF env U Γ d :=
-  match d with
-  | .vlam .. => IsType.weakN_iff henv hΓ' W
-  | .vlet .. => HasType.weakN_iff henv hΓ' W
-
 namespace VLCtx
 
 variable! (henv : Ordered env) in
@@ -278,7 +248,7 @@ theorem FVLift'.fvars_sublist (W : FVLift' Δ Δ' dk n k) : Δ.fvars <+ Δ'.fvar
   induction W with
   | refl => exact .refl _
   | skip_fvar _ _ _ ih => exact .cons _ ih
-  | cons_fvar _ _ _ _ ih => exact .cons₂ _ ih
+  | cons_fvar _ _ _ _ ih => exact .cons_cons _ ih
   | cons_bvar _ _ ih => exact ih
 
 theorem FVLift'.bvars_eq (W : FVLift' Δ Δ' dk n k) : Δ'.bvars = Δ.bvars := by
@@ -565,12 +535,18 @@ inductive SortList : VLCtx → List VLevel → Prop
 
 end VLCtx
 
-theorem TrProj.weak' (W : Ctx.Lift' n Γ Γ')
-    (H : TrProj Γ s i e e') : TrProj Γ' s i (e.lift' n) (e'.lift' n) := sorry
+theorem TrProj.weak' (henv : env.Ordered) (W : Ctx.Lift' n Γ Γ')
+    (H : TrProj env U Γ s i e e') :
+    TrProj env U Γ' s i (e.lift' n) (e'.lift' n) := by
+  obtain ⟨view, levels, params, hname, hproj⟩ := H
+  exact ⟨view, levels, params.map (fun param => param.lift' n),
+    hname, hproj.weak' henv W⟩
 
-theorem TrProj.weakN (W : Ctx.LiftN n k Γ Γ')
-    (H : TrProj Γ s i e e') : TrProj Γ' s i (e.liftN n k) (e'.liftN n k) := by
-  simpa [VExpr.lift'_consN_skipN] using H.weak' <| Ctx.liftN_iff_lift'.1 W
+theorem TrProj.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ')
+    (H : TrProj env U Γ s i e e') :
+    TrProj env U Γ' s i (e.liftN n k) (e'.liftN n k) := by
+  simpa [VExpr.lift'_consN_skipN] using
+    H.weak' henv (Ctx.liftN_iff_lift'.1 W)
 
 /-! ## Replaying closed metadata types -/
 
@@ -620,10 +596,8 @@ theorem TrTypeExpr.to_trExprS
     exact .forallE ⟨u, hty⟩ ⟨v, hbody⟩
       (ihty hΔ ⟨_, hty⟩) (ihbody ⟨hΔ, ⟨u, hty⟩⟩ ⟨_, hbody⟩)
 
-/- `TrExprS` still contains the sorried `TrProj` branch, so even this
-projection-free fragment inherits that dependency through its result type. -/
 /--
-info: 'Lean4Lean.TrTypeExpr.to_trExprS' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+info: 'Lean4Lean.TrTypeExpr.to_trExprS' depends on axioms: [propext, Classical.choice, Quot.sound]
 -/
 #guard_msgs in
 #print axioms TrTypeExpr.to_trExprS
@@ -650,7 +624,7 @@ theorem TrExprS.weakFV' (W : VLCtx.FVLift' Δ Δ' dk n k) (hΔ' : Δ'.WF env Us.
     exact .letE h1 (ih1 W hΔ') (ih2 W hΔ') (ih3 (W.cons_bvar _) ⟨hΔ', nofun, h1⟩)
   | lit h1 _ ih => exact .lit h1 (ih W hΔ')
   | mdata _ ih => exact .mdata (ih W hΔ')
-  | proj _ h2 ih => exact .proj (ih W hΔ') (h2.weak' W.toCtx)
+  | proj _ h2 ih => exact .proj (ih W hΔ') (h2.weak' henv W.toCtx)
 
 variable! (henv : WF env) in
 theorem TrExpr.weakFV' (W : VLCtx.FVLift' Δ Δ' dk n k) (hΔ' : Δ'.WF env Us.length)
@@ -689,7 +663,7 @@ theorem TrExprS.weakBV (W : VLCtx.BVLift Δ Δ' dn dk n k)
     refine .lit h1 (Expr.liftLooseBVars_eq_self ?_ ▸ ih W :)
     exact Closed.toConstructor.looseBVarRange_le
   | mdata _ ih => exact .mdata (ih W)
-  | proj _ h2 ih => exact .proj (ih W) (h2.weakN W.toCtx)
+  | proj _ h2 ih => exact .proj (ih W) (h2.weakN henv W.toCtx)
 
 variable! (henv : WF env) in
 theorem TrExpr.weakBV (W : VLCtx.BVLift Δ Δ' dn dk n k)
@@ -703,16 +677,30 @@ theorem HasType.skips (W : Ctx.LiftN n k Γ Γ')
   IsDefEq.skips henv hΓ' W h1 h2 h2
 
 theorem TrProj.weak'_inv (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U))
-    (W : Ctx.Lift' l Γ Γ') : TrProj Γ' s i (e.lift' l) e' → ∃ e', TrProj Γ s i e e' := sorry
+    (W : Ctx.Lift' l Γ Γ') :
+    TrProj env U Γ' s i (e.lift' l) e' →
+      ∃ e', TrProj env U Γ s i e e' := by
+  rintro ⟨view, levels, params, hname, hproj⟩
+  obtain ⟨params', result, hresult⟩ :=
+    henv.registeredStructureHeadInversion.weak'_inv hΓ' W hproj
+  exact ⟨result, view, levels, params', hname, hresult⟩
 
 theorem TrProj.defeqDFC (henv : VEnv.WF env) (hΓ : env.IsDefEqCtx U [] Γ₁ Γ₂)
-    (he : env.IsDefEqU U Γ₁ e₁ e₂) (H : TrProj Γ₁ s i e₁ e') :
-    ∃ e', TrProj Γ₂ s i e₂ e' := sorry
-
-variable! {env env' : VEnv} (henv : env ≤ env') in
-nonrec theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLits l
-  | .natVal _, ⟨_, H⟩ => ⟨_, henv.1 H⟩
-  | .strVal _, ⟨⟨_, H1⟩, ⟨_, H2⟩⟩ => ⟨⟨_, henv.1 H1⟩, ⟨_, henv.1 H2⟩⟩
+    (he : env.IsDefEqU U Γ₁ e₁ e₂) (H : TrProj env U Γ₁ s i e₁ e') :
+    ∃ e', TrProj env U Γ₂ s i e₂ e' := by
+  obtain ⟨view, levels, params, hname, hproj⟩ := H
+  have he₂ : env.HasType U Γ₂ e₂
+      (view.structureType levels params) :=
+    (hproj.majorType.defeqU_l henv hΓ.isType he).defeqDFC
+      henv.ordered hΓ
+  obtain ⟨result, hresult⟩ :=
+    hproj.defeqDFC henv.ordered hΓ he₂
+  exact ⟨result, view, levels, params, hname, hresult⟩
+
+theorem TrProj.mono {env env' : VEnv} (henv : env ≤ env')
+    (H : TrProj env U Γ s i e e') : TrProj env' U Γ s i e e' := by
+  obtain ⟨view, levels, params, hname, hproj⟩ := H
+  exact ⟨view, levels, params, hname, hproj.mono henv⟩
 
 variable! {env env' : VEnv} (henv : env ≤ env') in
 theorem TrExprS.mono (H : TrExprS env Us Δ e e') : TrExprS env' Us Δ e e' := by
@@ -727,7 +715,7 @@ theorem TrExprS.mono (H : TrExprS env Us Δ e e') : TrExprS env' Us Δ e e' := b
   | letE h1 _ _ _ ih1 ih2 ih3 => exact .letE (h1.mono henv) ih1 ih2 ih3
   | lit h1 _ ih => refine .lit (h1.mono henv) ih
   | mdata _ ih => exact .mdata ih
-  | proj _ h2 ih => exact .proj ih h2
+  | proj _ h2 ih => exact .proj ih (h2.mono henv)
 
 variable! {env env' : VEnv} (henv : env ≤ env') in
 theorem TrExpr.mono (H : TrExpr env Us Δ e e') : TrExpr env' Us Δ e e' :=
@@ -742,11 +730,6 @@ inductive VLCtx.IsDefEq : VLCtx → VLCtx → Prop
     VLocalDecl.IsDefEq env U Δ₁.toCtx d₁ d₂ →
     VLCtx.IsDefEq ((ofv, d₁) :: Δ₁) ((ofv, d₂) :: Δ₂)
 
-variable! (henv : Ordered env) (hΓ : OnCtx Γ (IsType env U)) in
-theorem VLocalDecl.IsDefEq.refl : ∀ {d}, VLocalDecl.WF env U Γ d → VLocalDecl.IsDefEq env U Γ d d
-  | .vlam _, ⟨_, h1⟩ => .vlam h1
-  | .vlet .., h1 => let ⟨_, h2⟩ := h1.isType henv hΓ; .vlet h1 h2
-
 variable! (henv : Ordered env) in
 theorem VLCtx.IsDefEq.refl : ∀ {Δ}, VLCtx.WF env U Δ → VLCtx.IsDefEq env U Δ Δ
   | [], _ => .nil
@@ -771,20 +754,10 @@ theorem VLCtx.IsDefEq.bvars : VLCtx.IsDefEq env U Δ₁ Δ₂ → Δ₁.bvars =
   | .cons (ofv := some _) h1 _ _ => by
       simp only [VLCtx.bvars, h1.bvars]
 
-theorem VLocalDecl.IsDefEq.wf : VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.WF env U Γ d₁
-  | .vlam h3 => ⟨_, h3.hasType.1⟩
-  | .vlet h3 _ => h3.hasType.1
-
 theorem VLCtx.IsDefEq.wf : VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.WF env U Δ₁
   | .nil => ⟨⟩
   | .cons h1 h2 h3 => ⟨h1.wf, h2, h3.wf⟩
 
-theorem VLocalDecl.IsDefEq.mono (henv : env ≤ env') :
-    VLocalDecl.IsDefEq env U Γ d₁ d₂ →
-      VLocalDecl.IsDefEq env' U Γ d₁ d₂
-  | .vlam h => .vlam (h.mono henv)
-  | .vlet h₁ h₂ => .vlet (h₁.mono henv) (h₂.mono henv)
-
 theorem VLCtx.IsDefEq.mono (henv : env ≤ env') :
     VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.IsDefEq env' U Δ₁ Δ₂
   | .nil => .nil
@@ -872,16 +845,6 @@ theorem VLCtx.IsDefEqFVars.find?_uniq (henv : VEnv.WF env)
               | vlam => exact ⟨h₂.weakN henv .one, h₃.weak henv⟩
               | vlet => simpa [VLocalDecl.depth] using ⟨h₂, h₃⟩
 
-theorem VLocalDecl.IsDefEq.symm :
-    VLocalDecl.IsDefEq env U Δ d₁ d₂ → VLocalDecl.IsDefEq env U Δ d₂ d₁
-  | .vlam h1 => .vlam h1.symm
-  | .vlet h1 h2 => .vlet (h2.defeqDF h1.symm) h2.symm
-
-theorem VLocalDecl.IsDefEq.defeqDFC (henv : Ordered env) (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂)
-    : VLocalDecl.IsDefEq env U Γ₁ d₁ d₂ → VLocalDecl.IsDefEq env U Γ₂ d₁ d₂
-  | .vlam h1 => .vlam (h1.defeqDFC henv hΓ)
-  | .vlet h1 h2 => .vlet (h1.defeqDFC henv hΓ) (h2.defeqDFC henv hΓ)
-
 variable! (henv : Ordered env) in
 theorem VLCtx.IsDefEq.symm : VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.IsDefEq env U Δ₂ Δ₁
   | .nil => .nil
@@ -975,7 +938,11 @@ theorem TrExpr.fvarsIn (H : TrExpr env Us Δ e e') : FVarsIn (· ∈ Δ.fvars) e
 theorem TrExpr.fvarsList (H : TrExpr env Us Δ e e') : e.fvarsList ⊆ Δ.fvars :=
   (fvarsIn_iff.1 H.fvarsIn).1
 
-theorem TrProj.wf (H1 : TrProj Δ s i e e') (H2 : VExpr.WF env U Γ e) : VExpr.WF env U Γ e' := sorry
+theorem TrProj.wf (H1 : TrProj env U Γ s i e e')
+    (_H2 : VExpr.WF env U Γ e) : VExpr.WF env U Γ e' := by
+  obtain ⟨view, levels, params, _hname, hproj⟩ := H1
+  obtain ⟨code, _hcode, rfl, hprojector⟩ := hproj.program
+  exact ⟨_, hprojector.app hproj.majorType⟩
 
 theorem TrExpr.wf (H : TrExpr env Us Δ e e') : VExpr.WF env Us.length Δ.toCtx e' :=
   let ⟨_, _, _, H⟩ := H; ⟨_, H.hasType.2⟩
@@ -1018,9 +985,14 @@ theorem TrExpr.app (henv : VEnv.WF env) (hΔ : OnCtx Δ.toCtx (env.IsType Us.len
   ⟨_, .app h3.hasType.1 h4.hasType.1 s3 s4, _, h3.appDF h4⟩
 
 variable! (henv : VEnv.WF env) (hΓ : IsDefEqCtx env U [] Γ₁ Γ₂) in
-theorem TrProj.uniq (H1 : TrProj Γ₁ s₁ i e₁ e₁') (H2 : TrProj Γ₂ s₂ i e₂ e₂')
+theorem TrProj.uniq (H1 : TrProj env U Γ₁ s₁ i e₁ e₁')
+    (H2 : TrProj env U Γ₂ s₂ i e₂ e₂')
     (H : env.IsDefEqU U Γ₁ e₁ e₂) :
-    env.IsDefEqU U Γ₁ e₁' e₂' := sorry
+    env.IsDefEqU U Γ₁ e₁' e₂' := by
+  obtain ⟨view₁, levels₁, params₁, _hname₁, hproj₁⟩ := H1
+  obtain ⟨view₂, levels₂, params₂, _hname₂, hproj₂⟩ := H2
+  exact henv.registeredStructureHeadInversion.unique
+    hΓ hproj₁ hproj₂ H
 
 variable! (henv : VEnv.WF env) {Us : List Name} (hΔ : VLCtx.IsDefEq env Us.length Δ₁ Δ₂) in
 theorem TrExprS.uniq (H1 : TrExprS env Us Δ₁ e e₁) (H2 : TrExprS env Us Δ₂ e e₂) :
@@ -1253,7 +1225,8 @@ theorem TrExpr.mdata (h : TrExpr env Us Δ e e') : TrExpr env Us Δ (.mdata d e)
   let ⟨_, s2, h2⟩ := h; ⟨_, .mdata s2, h2⟩
 
 theorem TrExpr.proj {env Us Δ e e' s i e''} (henv : VEnv.WF env) (hΔ : VLCtx.WF env Us.length Δ)
-    (H : TrExpr env Us Δ e e') (H2 : TrProj Δ.toCtx s i e' e'') :
+    (H : TrExpr env Us Δ e e')
+    (H2 : TrProj env Us.length Δ.toCtx s i e' e'') :
     TrExpr env Us Δ (.proj s i e) e'' :=
   let ⟨_, s2, h2⟩ := H
   have ⟨_, H2'⟩ := H2.defeqDFC henv (.refl hΔ) h2.symm
@@ -1386,8 +1359,14 @@ theorem TrExprS.instN_var (W : VLCtx.InstN Δ₀ e₀' A₀ dk k Δ₁ Δ) (H :
         refine ⟨_, _, h, ?_, rfl⟩
         cases d <;> simp [VLocalDecl.depth, VLocalDecl.inst, VExpr.lift_instN_lo]
 
-theorem TrProj.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
-    (H : TrProj Γ₁ s i e e') : TrProj Γ s i (e.inst e₀ k) (e'.inst e₀ k) := sorry
+theorem TrProj.instN (henv : env.Ordered)
+    (h₀ : env.HasType U Γ₀ e₀ A₀)
+    (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ)
+    (H : TrProj env U Γ₁ s i e e') :
+    TrProj env U Γ s i (e.inst e₀ k) (e'.inst e₀ k) := by
+  obtain ⟨view, levels, params, hname, hproj⟩ := H
+  exact ⟨view, levels, params.map (fun param => param.inst e₀ k),
+    hname, hproj.instN henv W h₀⟩
 
 variable! (henv : Ordered env) (h₀ : TrExprS env Us Δ₀ e₀ e₀')
   (t₀ : env.HasType Us.length Δ₀.toCtx e₀' A₀) in
@@ -1410,7 +1389,7 @@ theorem TrExprS.instN (W : VLCtx.InstN Δ₀ e₀' A₀ dk k Δ₁ Δ) (H : TrEx
     refine .lit h1 (Expr.instantiate1'_eq_self ?_ ▸ ih W :)
     exact Closed.toConstructor.looseBVarRange_le
   | mdata _ ih => exact .mdata (ih W)
-  | proj _ h2 ih => exact .proj (ih W) (h2.instN W.toCtx)
+  | proj _ h2 ih => exact .proj (ih W) (h2.instN henv t₀ W.toCtx)
 
 theorem TrExprS.inst {Δ : VLCtx} (henv : Ordered env)
     (t₀ : env.HasType Us.length Δ.toCtx e₀' A₀)
@@ -1616,7 +1595,7 @@ theorem ofLevel_isNeverZero (h : VLevel.ofLevel Us u = some u') (H : u.isNeverZe
     exact H.elim (ih1 h1 · _ h.1) (ih2 h2 · _ h.2)
   | imax _ _ ih1 ih2 =>
     obtain ⟨_, h1, _, h2, rfl⟩ := h
-    simp [VLevel.eval, Nat.imax, ih2 h2 H ls]
+    simp [VLevel.eval, Lean.Nat.imax, ih2 h2 H ls]
 
 theorem ofLevel_isAlwaysZero (h : VLevel.ofLevel Us u = some u') (H : u.isAlwaysZero) :
     u' ≈ .zero := by
@@ -1629,7 +1608,7 @@ theorem ofLevel_isAlwaysZero (h : VLevel.ofLevel Us u = some u') (H : u.isAlways
     simp [VLevel.eval, VLevel.equiv_def.1 (ih1 h1 H.1) ls, VLevel.equiv_def.1 (ih2 h2 H.2) ls]
   | imax _ _ _ ih2 =>
     obtain ⟨_, _, _, h2, rfl⟩ := h
-    simp [VLevel.eval, Nat.imax, VLevel.equiv_def.1 (ih2 h2 H) ls]
+    simp [VLevel.eval, Lean.Nat.imax, VLevel.equiv_def.1 (ih2 h2 H) ls]
 
 theorem ofLevel_mkLevelIMax'
     (h1 : VLevel.ofLevel Us u = some u') (h2 : VLevel.ofLevel Us v = some v') :
@@ -1654,9 +1633,114 @@ theorem ofLevel_mkLevelIMax'
   · simp_all; exact VLevel.imax_self.symm
   simp [VLevel.ofLevel]; exact ⟨_, ⟨_, h1, _, h2, rfl⟩, rfl⟩
 
-variable! {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') in
-theorem TrProj.instL (H : TrProj Γ s i e e') :
-    TrProj (Γ.map (VExpr.instL ls)) s i (e.instL ls) (e'.instL ls) := sorry
+variable! {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U')
+    (hU : U = ls.length) in
+theorem TrProj.instL (H : TrProj env U Γ s i e e') :
+    TrProj env U' (Γ.map (VExpr.instL ls)) s i
+      (e.instL ls) (e'.instL ls) := by
+  obtain ⟨view, levels, params, hname, hproj⟩ := H
+  exact ⟨view, levels.map (VLevel.inst ls),
+    params.map (VExpr.instL ls), hname, hproj.instL hls⟩
+
+/-- The structural interface of Verify's projection translation.  The bundle
+keeps the seven laws available as one coherent capability while the named
+theorems above remain the compatibility surface for existing callers. -/
+structure TrProj.StructuralLaws (env : VEnv) : Prop where
+  weakening : ∀ {U n Γ Γ' s i e e'},
+    Ctx.Lift' n Γ Γ' → TrProj env U Γ s i e e' →
+      TrProj env U Γ' s i (e.lift' n) (e'.lift' n)
+  inverseWeakening : ∀ {U l Γ Γ' s i e e'},
+    OnCtx Γ' (env.IsType U) → Ctx.Lift' l Γ Γ' →
+      TrProj env U Γ' s i (e.lift' l) e' →
+        ∃ result, TrProj env U Γ s i e result
+  contextDefEq : ∀ {U Γ₁ Γ₂ s i e₁ e₂ result},
+    env.IsDefEqCtx U [] Γ₁ Γ₂ → env.IsDefEqU U Γ₁ e₁ e₂ →
+      TrProj env U Γ₁ s i e₁ result →
+        ∃ result', TrProj env U Γ₂ s i e₂ result'
+  wellFormed : ∀ {U Γ s i e result},
+    TrProj env U Γ s i e result → VExpr.WF env U Γ e →
+      VExpr.WF env U Γ result
+  unique : ∀ {U Γ₁ Γ₂ s₁ s₂ i e₁ e₂ result₁ result₂},
+    env.IsDefEqCtx U [] Γ₁ Γ₂ →
+      TrProj env U Γ₁ s₁ i e₁ result₁ →
+      TrProj env U Γ₂ s₂ i e₂ result₂ →
+      env.IsDefEqU U Γ₁ e₁ e₂ →
+        env.IsDefEqU U Γ₁ result₁ result₂
+  termSubstitution : ∀ {U Γ₀ Γ₁ Γ s i e e' e₀ A₀ k},
+    env.HasType U Γ₀ e₀ A₀ → Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ →
+      TrProj env U Γ₁ s i e e' →
+        TrProj env U Γ s i (e.inst e₀ k) (e'.inst e₀ k)
+  universeInstantiation : ∀ {U U' Γ s i e e'} {ls : List VLevel},
+    (∀ level ∈ ls, level.WF U') → U = ls.length →
+      TrProj env U Γ s i e e' →
+        TrProj env U' (Γ.map (VExpr.instL ls)) s i
+          (e.instL ls) (e'.instL ls)
+
+/-- Every well-formed environment supplies the complete projection structural
+interface. -/
+theorem TrProj.structuralLaws (henv : VEnv.WF env) :
+    TrProj.StructuralLaws env where
+  weakening W H := H.weak' henv.ordered W
+  inverseWeakening hΓ' W H := H.weak'_inv henv hΓ' W
+  contextDefEq hΓ he H := H.defeqDFC henv hΓ he
+  wellFormed H he := H.wf he
+  unique hΓ H1 H2 he := H1.uniq henv hΓ H2 he
+  termSubstitution h₀ W H := H.instN henv.ordered h₀ W
+  universeInstantiation hls hU H := H.instL hls hU
+
+/-!
+The guards below pin both the proved laws and the inherited Tier-R boundary.
+In particular, they distinguish local proof closure from the remaining public
+registered-head inversion dependency.
+-/
+
+/--
+info: 'Lean4Lean.TrProj.weak'' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.weak'
+
+/--
+info: 'Lean4Lean.TrProj.weak'_inv' depends on axioms: [propext, sorryAx, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.weak'_inv
+
+/--
+info: 'Lean4Lean.TrProj.defeqDFC' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.defeqDFC
+
+/--
+info: 'Lean4Lean.TrProj.wf' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.wf
+
+/--
+info: 'Lean4Lean.TrProj.uniq' depends on axioms: [propext, sorryAx, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.uniq
+
+/--
+info: 'Lean4Lean.TrProj.instN' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.instN
+
+/--
+info: 'Lean4Lean.TrProj.instL' depends on axioms: [propext, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.instL
+
+/--
+info: 'Lean4Lean.TrProj.structuralLaws' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrProj.structuralLaws
 
 section
 
@@ -1764,7 +1848,7 @@ theorem TrExprS.instL (H : TrExprS env ps Δ e e') :
   | mdata _ ih => exact .mdata (ih hΔ)
   | proj _ h2 ih =>
     exact .proj henv (hΔ.instL Hls') (ih hΔ)
-      (VLCtx.instL_toCtx _ ▸ h2.instL Hls')
+      (VLCtx.instL_toCtx _ ▸ h2.instL Hls' eq')
 
 theorem TrExpr.instL (H : TrExpr env ps Δ e e') :
     TrExpr env Us (Δ.instL ls') (e.instantiateLevelParams ps ls) (e'.instL ls') :=
@@ -1874,6 +1958,186 @@ theorem TrExprS.unique' (hΔ : IsUniqueCtx Δ₁ Δ₂) (H : IsUnique e)
 theorem TrExprS.unique (H : IsUnique e)
     (H1 : TrExprS env Us Δ e e₁) (H2 : TrExprS env Us Δ e e₂) : e₁ = e₂ := H1.unique' .base H H2
 
+/-- A successful lookup transfers along value-preserving context alignment:
+the found value is identical and only the (discarded) type component may
+differ. -/
+theorem TrExprS.IsUniqueCtx.find?_transfer (hΔ : IsUniqueCtx Δ₁ Δ₂)
+    (H : Δ₁.find? v = some (e, A)) : ∃ A₂, Δ₂.find? v = some (e, A₂) := by
+  induction hΔ generalizing v e A with
+  | base => exact ⟨A, H⟩
+  | @cons Δ₁' Δ₂' d₁ d₂ ofv _ hd ih =>
+    revert H; simp only [VLCtx.find?]; split
+    next heq =>
+      simp only [Option.some.injEq, Prod.mk.injEq]
+      rintro ⟨rfl, rfl⟩
+      cases hd <;> exact ⟨_, rfl, rfl⟩
+    next v' heq =>
+      rintro h
+      simp only [Bind.bind, Option.bind_eq_some_iff] at h
+      obtain ⟨⟨e₁, A₁⟩, h1, h2⟩ := h
+      simp only [Option.some.injEq, Prod.mk.injEq] at h2
+      obtain ⟨rfl, rfl⟩ := h2
+      obtain ⟨A₂, h₂⟩ := ih h1
+      have hdep : d₁.depth = d₂.depth := by cases hd <;> rfl
+      refine ⟨VExpr.liftN d₂.depth A₂, ?_⟩
+      simp only [Bind.bind, Option.bind_eq_some_iff]
+      exact ⟨(e₁, A₂), h₂, by rw [hdep]⟩
+
+/-- Every strict translation of an unfolded natural-number literal is the
+canonical numeral: the constructor spine pins the Theory value
+syntactically. -/
+theorem TrExprS.natLitToConstructor_eq :
+    ∀ {n : Nat} {w}, TrExprS env Us Δ (Expr.natLitToConstructor n) w →
+      w = VExpr.natLit n
+  | 0, w, h => by
+    have h : TrExprS env Us Δ (.const ``Nat.zero []) w := h
+    cases h with
+    | const h1 h2 h3 =>
+      obtain rfl : _ = ([] : List VLevel) := by simpa using h2.symm
+      rfl
+  | n+1, w, h => by
+    have h : TrExprS env Us Δ (.app (.const ``Nat.succ []) (.lit (.natVal n))) w := h
+    cases h with
+    | app h1 h2 hf ha =>
+      cases hf with
+      | const hf1 hf2 hf3 =>
+        obtain rfl : _ = ([] : List VLevel) := by simpa using hf2.symm
+        cases ha with
+        | lit ha1 ha2 =>
+          cases natLitToConstructor_eq ha2
+          rfl
+
+/-- Every strict translation of an unfolded character-list literal is the
+canonical Theory list. -/
+theorem TrExprS.strLitToConstructor_chars_eq :
+    ∀ {cs : List Char} {w},
+      TrExprS env Us Δ
+        (cs.foldr (init := .app (.const ``List.nil [.zero]) (.const ``Char []))
+          fun c e =>
+            .app (.app (.app (.const ``List.cons [.zero]) (.const ``Char []))
+              (.app (.const ``Char.ofNat []) (.lit (.natVal c.toNat)))) e) w →
+      w = VExpr.listCharLit cs
+  | [], w, h => by
+    cases h with
+    | app h1 h2 hf ha =>
+      cases hf with
+      | const hf1 hf2 hf3 =>
+        simp [VLevel.ofLevel] at hf2
+        obtain rfl := hf2
+        cases ha with
+        | const ha1 ha2 ha3 =>
+          obtain rfl : _ = ([] : List VLevel) := by simpa using ha2.symm
+          rfl
+  | c :: cs, w, h => by
+    cases h with
+    | app h1 h2 hf ha =>
+      cases strLitToConstructor_chars_eq ha
+      cases hf with
+      | app hg1 hg2 hgf hga =>
+        cases hgf with
+        | app hh1 hh2 hhf hha =>
+          cases hhf with
+          | const hi1 hi2 hi3 =>
+            simp [VLevel.ofLevel] at hi2
+            obtain rfl := hi2
+            cases hha with
+            | const hj1 hj2 hj3 =>
+              obtain rfl : _ = ([] : List VLevel) := by simpa using hj2.symm
+              cases hga with
+              | app hk1 hk2 hkf hka =>
+                cases hkf with
+                | const hl1 hl2 hl3 =>
+                  obtain rfl : _ = ([] : List VLevel) := by simpa using hl2.symm
+                  cases hka with
+                  | lit hm1 hm2 =>
+                    cases natLitToConstructor_eq hm2
+                    rfl
+
+/-- Every strict translation of a literal's constructor unfolding is the
+canonical `VExpr.trLiteral` value. -/
+theorem TrExprS.toConstructor_eq {l : Literal} {w}
+    (h : TrExprS env Us Δ l.toConstructor w) : w = VExpr.trLiteral l := by
+  match l with
+  | .natVal n => exact natLitToConstructor_eq h
+  | .strVal s =>
+    have h : TrExprS env Us Δ (.app (.const ``String.ofList [])
+      (s.toList.foldr (init := .app (.const ``List.nil [.zero]) (.const ``Char []))
+        fun c e =>
+          .app (.app (.app (.const ``List.cons [.zero]) (.const ``Char []))
+            (.app (.const ``Char.ofNat []) (.lit (.natVal c.toNat)))) e)) w := h
+    cases h with
+    | app h1 h2 hf ha =>
+      cases strLitToConstructor_chars_eq ha
+      cases hf with
+      | const hf1 hf2 hf3 =>
+        obtain rfl : _ = ([] : List VLevel) := by simpa using hf2.symm
+        rfl
+
+/-- The Verify traversal of `Literal.toConstructor` and the direct Theory
+encoding form one ready, well-formed literal value. -/
+theorem TrExprS.toConstructor_ready {l : Literal} {w}
+    (hready : env.PreludeReady) (hcontains : env.ContainsLits l)
+    (h : TrExprS env Us Δ l.toConstructor w) :
+    w = VExpr.trLiteral l ∧ VExpr.WF env U [] w := by
+  have heq := h.toConstructor_eq
+  refine ⟨heq, ?_⟩
+  rw [heq]
+  exact hready.trLiteral_wf l hcontains
+
+/-- The deterministic translator agrees with every strict-translation
+derivation over any value-preserving context alignment: on the `IsUnique`
+fragment, `trExprS?` computes exactly the derivation's Theory value.  This
+is the replay engine for choice-free semantic packaging — a `Nonempty`
+translation witness plus this agreement pins the computed value. -/
+theorem TrExprS.trExprS?_eq' (hΔ : IsUniqueCtx Δ₁ Δ₂)
+    (H : TrExprS env Us Δ₁ e e') (hu : IsUnique e) :
+    trExprS? Us Δ₂ e = some e' := by
+  induction H generalizing Δ₂ with
+  | bvar h1 =>
+    obtain ⟨A₂, h2⟩ := hΔ.find?_transfer h1
+    simp [trExprS?, h2]
+  | fvar h1 =>
+    obtain ⟨A₂, h2⟩ := hΔ.find?_transfer h1
+    simp [trExprS?, h2]
+  | sort h1 => simp [trExprS?, h1]
+  | const h1 h2 h3 => simp [trExprS?, h2]
+  | app h1 h2 _ _ ih1 ih2 =>
+    simp [trExprS?, ih1 hΔ hu.1, ih2 hΔ hu.2]
+  | lam h1 _ _ ih1 ih2 =>
+    simp [trExprS?, ih1 hΔ hu.1, ih2 (hΔ.cons .vlam) hu.2]
+  | forallE h1 h2 _ _ ih1 ih2 =>
+    simp [trExprS?, ih1 hΔ hu.1, ih2 (hΔ.cons .vlam) hu.2]
+  | letE h1 _ _ _ ih1 ih2 ih3 =>
+    simp [trExprS?, ih2 hΔ hu.1, ih3 (hΔ.cons .vlet) hu.2]
+  | lit h1 h2 ih =>
+    cases h2.toConstructor_eq
+    simp [trExprS?]
+  | mdata _ ih => simpa [trExprS?] using ih hΔ hu
+  | proj h1 h2 => cases hu
+
+/-- Deterministic-translator agreement in a fixed context. -/
+theorem TrExprS.trExprS?_eq (H : TrExprS env Us Δ e e') (hu : IsUnique e) :
+    trExprS? Us Δ e = some e' :=
+  H.trExprS?_eq' .base hu
+
+/-- Executable totality on the unique fragment: any translation witness
+guarantees the deterministic translator succeeds. -/
+theorem TrExprS.trExprS?_isSome (hex : ∃ e', TrExprS env Us Δ e e')
+    (hu : IsUnique e) : (trExprS? Us Δ e).isSome := by
+  obtain ⟨e', H⟩ := hex
+  simp [H.trExprS?_eq hu]
+
+/-- Replay transfer: an existential translation witness holds of the computed
+translation itself.  Choice-free packagers pin their Theory data with this:
+compute by `trExprS?`, then transfer the `Nonempty`-level witness onto the
+computed value. -/
+theorem TrExprS.of_trExprS?_eq (hex : ∃ e', TrExprS env Us Δ e e')
+    (hu : IsUnique e) (h : trExprS? Us Δ e = some v) :
+    TrExprS env Us Δ e v := by
+  obtain ⟨e', H⟩ := hex
+  cases Option.some.inj ((H.trExprS?_eq hu).symm.trans h)
+  exact H
+
 theorem TrExprS.boolFalse (henv : env.HasPrimitives) (H : env.contains ``Bool) :
     TrExprS env Us Δ (toExpr false) .boolFalse ∧
     env.HasType Us.length Δ.toCtx .boolFalse .bool := by
@@ -1881,9 +2145,6 @@ theorem TrExprS.boolFalse (henv : env.HasPrimitives) (H : env.contains ``Bool) :
   cases henv.boolFalse H
   exact ⟨.const H rfl rfl, .const H nofun rfl⟩
 
-@[simp] theorem VExpr.instL_boolFalse : VExpr.boolFalse.instL ls = VExpr.boolFalse := by
-  simp [boolFalse, instL]
-
 theorem TrExprS.boolTrue (henv : env.HasPrimitives) (H : env.contains ``Bool) :
     TrExprS env Us Δ (toExpr true) .boolTrue ∧
     env.HasType Us.length Δ.toCtx .boolTrue .bool := by
@@ -1891,9 +2152,6 @@ theorem TrExprS.boolTrue (henv : env.HasPrimitives) (H : env.contains ``Bool) :
   cases henv.boolTrue H
   exact ⟨.const H rfl rfl, .const H nofun rfl⟩
 
-@[simp] theorem VExpr.instL_boolTrue : VExpr.boolTrue.instL ls = VExpr.boolTrue := by
-  simp [boolTrue, instL]
-
 theorem TrExprS.boolLit (henv : env.HasPrimitives) (H : env.contains ``Bool) (b : Bool) :
     TrExprS env Us Δ (toExpr b) (.boolLit b) ∧
     env.HasType Us.length Δ.toCtx (.boolLit b) .bool := by
@@ -1901,21 +2159,8 @@ theorem TrExprS.boolLit (henv : env.HasPrimitives) (H : env.contains ``Bool) (b
   | false => exact TrExprS.boolFalse henv H
   | true => exact TrExprS.boolTrue henv H
 
-@[simp] theorem VExpr.instL_boolLit : (VExpr.boolLit b).instL ls = VExpr.boolLit b := by
-  cases b <;> simp [boolLit]
-
 theorem FVarsIn.boolLit {b : Bool} : FVarsIn P (toExpr b) := by cases b <;> exact nofun
 
-theorem VExpr.WF.boolLit_has_type (wf : env.Ordered) (henv : env.HasPrimitives)
-    (hΓ : OnCtx Γ (env.IsType U)) (H : VExpr.WF env U Γ (.boolLit b)) : env.contains ``Bool := by
-  suffices env.HasType U Γ (.boolLit b) .bool by
-    have ⟨_, H⟩ := this.isType wf hΓ
-    have ⟨_, H, _⟩ := HasType.const_inv wf hΓ H
-    exact ⟨_, H⟩
-  cases b with have ⟨_, h1, h2, h3⟩ := let ⟨_, H⟩ := H; HasType.const_inv wf hΓ H
-  | false => cases henv.boolFalse h1; exact .const h1 h2 h3
-  | true => cases henv.boolTrue h1; exact .const h1 h2 h3
-
 theorem TrExprS.lit_has_type (H : TrExprS env Us Δ (.lit l) e') : env.ContainsLits l :=
   let .lit H _ := H; H
 
@@ -1932,9 +2177,6 @@ theorem TrExprS.natZero (henv : env.HasPrimitives) (H : env.contains ``Nat) :
   cases henv.natZero H
   exact ⟨.const H rfl rfl, .const H nofun rfl⟩
 
-@[simp] theorem VExpr.instL_natZero : VExpr.natZero.instL ls = .natZero := by
-  simp [natZero, instL]
-
 theorem TrExprS.natSucc (henv : env.HasPrimitives) (H : env.contains ``Nat) :
     TrExprS env Us Δ .natSucc .natSucc ∧
     env.HasType Us.length Δ.toCtx .natSucc (.forallE .nat .nat) := by
@@ -1942,9 +2184,6 @@ theorem TrExprS.natSucc (henv : env.HasPrimitives) (H : env.contains ``Nat) :
   cases henv.natSucc H
   exact ⟨.const H rfl rfl, .const H nofun rfl⟩
 
-@[simp] theorem VExpr.instL_natSucc : VExpr.natSucc.instL ls = .natSucc := by
-  simp [natSucc, instL]
-
 theorem TrExprS.natLit (henv : env.HasPrimitives) (H : env.contains ``Nat) (n) :
     TrExprS env Us Δ (.lit (.natVal n)) (.natLit n) ∧
     env.HasType Us.length Δ.toCtx (.natLit n) .nat := by
@@ -1952,9 +2191,6 @@ theorem TrExprS.natLit (henv : env.HasPrimitives) (H : env.contains ``Nat) (n) :
   | zero => exact let ⟨h1, h2⟩ := natZero henv H; ⟨.lit H h1, h2⟩
   | succ n ih => exact let ⟨h1, h2⟩ := natSucc henv H; ⟨.lit H (.app h2 ih.2 h1 ih.1), .app h2 ih.2⟩
 
-@[simp] theorem VExpr.instL_natLit : (VExpr.natLit n).instL ls = VExpr.natLit n := by
-  induction n <;> simp [*, natLit, instL]
-
 theorem TrExprS.stringOfList (henv : env.HasPrimitives) (H : env.contains ``String.ofList) :
     TrExprS env Us Δ (.const ``String.ofList []) .stringOfList ∧
     env.HasType Us.length Δ.toCtx .stringOfList (.forallE .listChar .string) := by
@@ -1969,14 +2205,6 @@ theorem TrExprS.charOfNat (henv : env.HasPrimitives) (H : env.contains ``Char.of
   cases henv.charOfNat H
   exact ⟨.const H rfl rfl, .const H nofun rfl⟩
 
-theorem VEnv.HasPrimitives.nat_of_charOfNat (wf : Ordered env) (henv : env.HasPrimitives)
-    (H : env.contains ``Char.ofNat) : env.contains ``Nat := by
-  let ⟨_, H⟩ := H
-  have ⟨_, H⟩ := wf.constWF (henv.charOfNat H ▸ H)
-  let ⟨⟨_, H⟩, _⟩ := H.forallE_inv wf
-  let ⟨_, H, _⟩ := H.const_inv wf trivial
-  exact ⟨_, H⟩
-
 theorem TrExprS.listChar (wf : env.Ordered) (henv : env.HasPrimitives)
     (H : env.contains ``String.ofList) :
     TrExprS env Us Δ (.app (.const ``List [.zero]) (.const ``Char [])) .listChar ∧
@@ -2047,10 +2275,6 @@ theorem TrExprS.trLiteral (wf : env.Ordered) (henv : env.HasPrimitives)
     have b := TrExprS.listCharLit wf henv H (Us := Us) (Δ := Δ) s.toList
     exact ⟨.lit H (.app a.2 b.2 a.1 (String.foldr_eq .. ▸ b.1)), a.2.app b.2⟩
 
-def VLocalDecl.ClosedN : VLocalDecl → (k : Nat := 0) → Prop
-  | .vlam A, k => A.ClosedN k
-  | .vlet A e, k => A.ClosedN k ∧ e.ClosedN k
-
 def VLCtx.Closed : VLCtx → Prop
   | [] => True
   | (none, _) :: _ => False
@@ -2396,3 +2620,41 @@ theorem AppStack.append {e : Expr} (H : AppStack env Us Δ (e.mkAppList as) e' b
 
 theorem AppStack.build {e : Expr} (H : TrExprS env Us Δ (e.mkAppList as) e') :
     ∃ e', AppStack env Us Δ e e' as := by simpa using AppStack.append (.head H)
+
+/-- Recover the pointwise strict translations of an application spine and
+rebuild the complete translated application.  Unlike the checker-facing
+`AppStack.toSpineWF`, this purely syntactic projection needs no expected
+function type and is therefore available to WHNF reduction. -/
+theorem AppStack.argsTranslation
+    (H : AppStack env Us Δ f f' args) :
+    ∃ args', args.Forall₂ (TrExprS env Us Δ) args' ∧
+      TrExprS env Us Δ (f.mkAppList args) (VExpr.appN f' args') := by
+  induction H with
+  | head h => exact ⟨[], .nil, by simpa⟩
+  | app hfun harg hf ha H ih =>
+    obtain ⟨args', hargs, hfull⟩ := ih
+    refine ⟨_ :: args', .cons ha hargs, ?_⟩
+    simpa [Expr.mkAppList, VExpr.appN] using hfull
+
+/-- A successful lookup on the left side of a pointwise list relation has a
+related lookup at the same position on the right. -/
+theorem List.Forall₂.getElem?_left
+    {α : Type u} {β : Type v} {R : α → β → Prop}
+    {xs : List α} {ys : List β} {i : Nat} {x : α}
+    (H : List.Forall₂ R xs ys) (hx : xs[i]? = some x) :
+    ∃ y : β, ys[i]? = some y ∧ R x y := by
+  induction H generalizing i with
+  | nil => simp at hx
+  | cons hxy _ ih =>
+    cases i with
+    | zero =>
+      simp at hx
+      subst x
+      exact ⟨_, rfl, hxy⟩
+    | succ i => simpa using ih (i := i) (by simpa using hx)
+
+/--
+info: 'Lean4Lean.TrExprS.toConstructor_ready' depends on axioms: [propext, Classical.choice, Quot.sound]
+-/
+#guard_msgs in
+#print axioms TrExprS.toConstructor_ready
diff --git a/Lean4Lean/Verify/VLCtx.lean b/Lean4Lean/Verify/VLCtx.lean
index f6c6d08c..2c5a7789 100644
--- a/Lean4Lean/Verify/VLCtx.lean
+++ b/Lean4Lean/Verify/VLCtx.lean
@@ -1,47 +1,11 @@
 import Lean4Lean.Verify.Expr
-import Lean4Lean.Theory.VExpr
+import Lean4Lean.Theory.LocalContext
 
 namespace Lean4Lean
 
 open Lean (FVarId Expr)
 
-inductive VLocalDecl where
-  | vlam (type : VExpr)
-  | vlet (type value : VExpr)
-
-def VLocalDecl.depth : VLocalDecl → Nat
-  | .vlam .. => 1
-  | .vlet .. => 0
-
-def VLocalDecl.value : VLocalDecl → VExpr
-  | .vlam .. => .bvar 0
-  | .vlet _ e => e
-
-def VLocalDecl.type' : VLocalDecl → VExpr
-  | .vlam A
-  | .vlet A _ => A
-
-def VLocalDecl.type : VLocalDecl → VExpr
-  | .vlam A => A.lift
-  | .vlet A _ => A
-
-def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl
-  | .vlam A, n => .vlam (A.lift' n)
-  | .vlet A e, n => .vlet (A.lift' n) (e.lift' n)
-
-def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl
-  | .vlam A, n, k => .vlam (A.liftN n k)
-  | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k)
-
-def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl
-  | .vlam A, e₀, k => .vlam (A.inst e₀ k)
-  | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k)
-
-def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl
-  | .vlam A, ls => .vlam (A.instL ls)
-  | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls)
-
-def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl)
+@[reducible] def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl)
 
 namespace VLCtx
 
diff --git a/README.md b/README.md
index ced940ee..412d98c8 100644
--- a/README.md
+++ b/README.md
@@ -106,6 +106,7 @@ If you run this as is (with no additional arguments), it will check every olean
     * `Axioms.lean`: theorems about upstream opaques that shouldn't be opaque
     * `Expr.lean`: correctness of basics on `Expr`
     * `Level.lean`: correctness of basics on `Level`
+    * `Level/Std.lean`: soundness of the standard-library level operations
     * `VLCtx.lean`: a "translation context" suitable for translating expressions
     * `LocalContext.lean`: properties of lean's `LocalContext` type
     * `NameGenerator.lean`: properties of the fresh name generator
diff --git a/divergences.md b/divergences.md
index 01bf8222..31f00674 100644
--- a/divergences.md
+++ b/divergences.md
@@ -6,8 +6,13 @@ This is a list of places where lean4lean deliberately has different behavior fro
 * [`Lean4Lean.Environment.checkPrimitiveDef`](Lean4Lean/Primitive.lean), `checkPrimitiveInductive`: Lean does not check that primitives are declared with the correct types and definitional behavior, except in the case of `Eq` which is used in the declaration of `Quot`. This is required for soundness, but Lean is able to get away with it because Lean ships its prelude and using an alternative prelude is not supported.
 * [`Lean4Lean.TypeChecker.Inner.inferType'`](Lean4Lean/TypeChecker.lean), literal case: The original code was not checking that the literal type actually exists. Again, this is okay provided that the prelude is trusted.
 * [`Lean4Lean.TypeChecker.Inner.tryStringLitExpansionCore`](Lean4Lean/TypeChecker.lean): there is a counterproductive `whnf` call in this function which is removed in Lean4lean.
-* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.31.0/src/Lean/Level.lean), `isEquiv`, `geq`: Lean's standard-library level operations currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. Lean4lean routes typechecker sort and constant-level-list equality through the verified primed `NormLevel` comparison in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean), a sound but incomplete under-approximation. The inductive front end still executes the standard operations, while its verified semantic gate excludes normalized-comparison-only acceptance until the core/project bridge is proved.
-* [`Lean4Lean.addDefinition`](Lean4Lean/Environment.lean), `Lean4Lean.addTheorem`: two calls ([1](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/environment.cpp#L183) [2](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/environment.cpp#L203)) are redundant and have been removed.
-* [`Lean4Lean.TypeChecker.Inner.inferLambda`](Lean4Lean/TypeChecker.lean), `inferLet`: lean4lean does the `ensureSort` call before extending the context, while [`infer_lambda`](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/type_checker.cpp#L124-L126) does it afterward. It's not clear whether this is actually unsound but it would require some very weird invariants to justify having unchecked things in the local context and hoping that they won't be used in the typing proof of that same expression.
+* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.33.0/src/Lean/Level.lean), `isEquiv`, `geq`: Lean's standard-library level operations currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. Lean4lean routes typechecker sort and constant-level-list equality through the primed comparisons in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) (`isEquiv'`, `isEquivList`), which are verified sound and complete for the `NormLevel` semantics and use the standard-library operations — themselves verified in [`Lean4Lean/Verify/LevelStd.lean`](Lean4Lean/Verify/LevelStd.lean) — as a sound fast path.
 * [`Lean4Lean.checkConstantVal`](Lean4Lean/Environment.lean): The original implementation would call `check` which sets the level params and then unsets them afterward, and then `ensure_sort` would run in a context without any level params. In lean4lean the monad is parameterized over level params, so they remain the same across the two calls.
-* [`Lean4Lean.TypeChecker.Inner.isProp`](Lean4Lean/TypeChecker.lean), [`Lean4Lean.toCtorWhenStruct`](Lean4Lean/Inductive/Reduce.lean): Lean decides whether a sort is `Prop` by comparing it syntactically against `Sort 0`. That misses `Sort (imax 1 0)`, which denotes `Prop` without being syntactically `zero`, and the mismatch between this test and the one used for proof irrelevance resulted in a soundness bug ([leanprover/lean4#14613](https://github.com/leanprover/lean4/pull/14613)). Lean4lean tests the level instead, but using `isAlwaysZero` instead of `isZero` in `isProp`, and `isNeverZero` instead of `!isAlwaysZero` in `toCtorWhenStruct` and `inferProj`. The lean check using `!isAlwaysZero` in `toCtorWhenStruct` would be unsound if not for the fact that the level algorithm rejects the true equation `imax 1 u ≤ u`: `inductive T.{u} : Sort u where mk : Bool → T` would allow proving false using a similar construction to the one in [#14613](https://github.com/leanprover/lean4/pull/14613).
+* [`Lean4Lean.toCtorWhenStruct`](Lean4Lean/Inductive/Reduce.lean), `inferProj`: both kernels now recognize `Prop` using normalized universe levels ([leanprover/lean4#14613](https://github.com/leanprover/lean4/pull/14613)). Lean4lean remains more conservative for uncertain levels, using `isNeverZero` where Lean uses `!isAlwaysZero`. Lean's choice would be unsound if its level algorithm did not reject the true equation `imax 1 u ≤ u`: `inductive T.{u} : Sort u where mk : Bool → T` would otherwise permit an analogue of the construction in #14613.
+* [`Lean4Lean.EquivManager.isEquiv`](Lean4Lean/EquivManager.lean), [`Lean4Lean.TypeChecker.Inner.isDefEqCore'`](Lean4Lean/TypeChecker.lean), `reduceProj`: when comparing two projections, and when reducing one, lean4lean uses only the projection index, while the C++ kernel also compares the structure name ([leanprover/lean4#14631](https://github.com/leanprover/lean4/pull/14631), [#14632](https://github.com/leanprover/lean4/pull/14632)). The name has already been checked by the time either happens: [`inferProj`](Lean4Lean/TypeChecker.lean) rejects `.proj S i e` unless the type of `e` whnfs to an application of `S` itself. Comparison and reduction only ever see projections that have been through type inference, so re-comparing the name there is redundant.
+* [`Lean4Lean.Environment.addInductive`](Lean4Lean/Inductive/Add.lean): [leanprover/lean4#14621](https://github.com/leanprover/lean4/pull/14621) rechecks the declarations produced by nested-inductive elimination — the restored constructor types, the restored recursor types and the recursor rules' right-hand sides. Lean4lean does not. Upstream describes these as redundant sanity checks that "may prevent soundness bugs if the nested-inductive code is still missing any required validations"; they establish no precondition that a later step consumes. Lean4lean aims to prove the elimination correct rather than to recheck its output, and a speculative check would only add proof obligations without contributing an invariant. The check of the nested applications `I Ds` from [#14577](https://github.com/leanprover/lean4/pull/14577) is kept, because those arguments are dropped from the auxiliary declarations and so are not covered by checking the block.
+* [`Lean4Lean.checkNoNestedAux`](Lean4Lean/Inductive/Add.lean): [leanprover/lean4#14616](https://github.com/leanprover/lean4/pull/14616) rejects the reserved `_nested` prefix in both the inductive types and the constructor types of a declaration; lean4lean checks only the constructor types. The bug that check fixes is specific to constructors: nested occurrences are rewritten to the auxiliary types in constructor types only (`replaceAllNested`), and rewritten back the same way (`restoreNested`), so an inductive's own type is carried through both directions verbatim and cannot acquire a type it was not checked at. A `_nested` name written in an inductive type also cannot resolve in the first place: the auxiliary types are declared in the same block, so they are not in the environment while that block's types are checked (unlike constructor types, which are checked once the block's types, auxiliaries included, are present), and they never survive into the final environment. Lean's check additionally reserves the whole `_nested` namespace against unrelated user declarations, which lean4lean does not.
+* [`Lean4Lean.ElimNestedInductive.Result.restoreNested`](Lean4Lean/Inductive/Add.lean), `restoreCtorName`: [leanprover/lean4#14632](https://github.com/leanprover/lean4/pull/14632) turned the `lean_assert`s in the nested-inductive restoration into kernel exceptions; lean4lean keeps `unreachable!` and `assert!`. The branches are unreachable: `restoreCtorName` runs only for the recursors of the auxiliary types the elimination generates, whose constructors are exactly the keys of `aux2nested`, and the nested occurrences stored there are applications of a constant by construction. Upstream's stated motivation is that the assertions vanish in a release build and the C++ consumers then read out of bounds; the corresponding accesses here are total, so there is nothing to read out of bounds. Note that if one of these invariants were broken anyway, `unreachable!` would continue with a default value rather than reject; the restored constructor and recursor types are re-checked in the final environment ([#14621](https://github.com/leanprover/lean4/pull/14621)), which lean4lean retains, but a restored rule constructor *name* is not covered by that pass.
+* [`Lean4Lean.FuelConfig`](Lean4Lean/FuelConfig.lean): since [leanprover/lean4#13956](https://github.com/leanprover/lean4/pull/13956), the native kernel bounds mutually recursive checking through the `maxRecDepth` option. Lean4lean exposes several independent fuel counters instead, because its Lean definitions also need explicit termination witnesses. Replay comparison therefore uses each implementation's default bound unless an explicit lean4lean fuel configuration is supplied.
+* [`Lean4Lean.addDefinition`](Lean4Lean/Environment.lean) (`unsafe` branch), [`addMutual`](Lean4Lean/Environment.lean): an `unsafe`/`partial` definition may be recursive, so its body is checked in an environment that already contains the declaration. The C++ kernel adds `constant_info(d)` there -- the full definition, value included -- so the body can delta-unfold the very constant being defined. Lean4lean adds it as an axiom of the same type instead: the body may still *refer* to the block's constants, but cannot unfold them. So for example `unsafe def foo : Nat := (fun (_ : foo = 1) => 1) rfl` is accepted by the C++ kernel, but rejected by L4L: checking the argument requires `foo =?= 1`, which succeeds by unfolding `foo` to its own body and reducing. Read literally, that rule makes a typing fact about the constant available while establishing it, and implementing this in `IsDefEq` directly degenerates completely, allowing even things like `unsafe def bar : Nat := "hi"` by using the typing judgment to justify itself. The gap is confined to `unsafe`/`partial` code, which carries no logical content.
+* [`Lean4Lean.addMutual`](Lean4Lean/Environment.lean): lean4lean requires the declarations of a mutual block to carry the same universe parameters and to have distinct names. Both checks are in kernel PRs that are not yet released ([leanprover/lean4#14608](https://github.com/leanprover/lean4/pull/14608), [#14632](https://github.com/leanprover/lean4/pull/14632)); the released kernel checks only that the safety annotations agree. Lean4lean needs them rather than merely matching them: the block is checked under a single `M.run`, whose level parameters are fixed for the whole run, and the model adds the block's constants one at a time with `VEnv.addConsts`, which fails on a repeated name.
diff --git a/flake.lock b/flake.lock
index b6cd9081..be751f6e 100644
--- a/flake.lock
+++ b/flake.lock
@@ -24,15 +24,15 @@
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1784744474,
-        "narHash": "sha256-9yx5PzXBkZ+160uquH4f7lCCPZGlzdc1Y2j+zOKRc54=",
-        "owner": "lenianiva",
+        "lastModified": 1786463392,
+        "narHash": "sha256-5ke9p2DFQcF0FxR/RyrYvZymoVcCR1zyVWlnhqfRyf0=",
+        "owner": "argumentcomputer",
         "repo": "lean4-nix",
-        "rev": "9edc9448c8fe9552ba2b66e6097abda6e14e5c6f",
+        "rev": "c41a770e44a990da275dad0f70da75f22197e597",
         "type": "github"
       },
       "original": {
-        "owner": "lenianiva",
+        "owner": "argumentcomputer",
         "repo": "lean4-nix",
         "type": "github"
       }
diff --git a/flake.nix b/flake.nix
index 77daa825..30b04217 100644
--- a/flake.nix
+++ b/flake.nix
@@ -15,7 +15,7 @@
     nixpkgs.follows = "lean4-nix/nixpkgs";
 
     # Lean 4 & Lake
-    lean4-nix.url = "github:lenianiva/lean4-nix";
+    lean4-nix.url = "github:argumentcomputer/lean4-nix";
 
     # Helper: flake-parts for easier outputs; follows the copy lean4-nix
     # already locks so the lock file carries a single flake-parts node
@@ -42,8 +42,12 @@
         pkgs,
         ...
       }: let
+        # Pinned Lean toolchain (a single sysroot derivation: bin/lean,
+        # bin/lake, lib, include), resolved from ./lean-toolchain by
+        # lean4-nix's vendored release table.
+        lean = lean4-nix.lib.${system}.fromToolchainFile ./lean-toolchain;
         # Lake package
-        lake2nix = pkgs.callPackage lean4-nix.lake {};
+        lake2nix = pkgs.callPackage lean4-nix.lake {inherit lean;};
         # Restrict the Lake build inputs to Lean-relevant files so edits to
         # unrelated files (CI, docs, the flake itself) don't invalidate the
         # cached Lean derivations. Covers the library/CLI/proof/test/audit
@@ -62,26 +66,17 @@
             (pkgs.lib.fileset.fileFilter (f: f.hasExt "lean") ./.)
           ];
         };
-        # Batteries v4.31.0 accidentally split deprecated recycling modules
-        # into a second Lake library with a dependency back to Batteries.  Its
-        # shared/static facets therefore form a cycle, which matters here
-        # because lake2nix exports those facets for downstream consumers.
-        # Backport the upstream fix released after the v4.31.0 tag.
-        batteries431CycleFix = pkgs.fetchurl {
-          url = "https://github.com/leanprover-community/batteries/commit/ba9a97018925ecc18fd8411d8c53de6056cf9dff.patch";
-          hash = "sha256-HjF68B7QUeioDcGT/q6SWQEqPp8o5OQqErfw5D9rdIY=";
-        };
         # Dependencies from lake-manifest.json (batteries). lean4-nix's
-        # default target guess ("batteries" -> "Batteries") is correct, so
-        # only the v4.31 shared/static cycle backport is needed.
+        # default target guess ("batteries" -> "Batteries") is correct, and
+        # batteries ≥ v4.32 ships the shared/static cycle fix that v4.31
+        # needed as a backported patch here.
         lakeDeps = lake2nix.buildDeps {
           src = leanSrc;
-          depOverride.batteries.patches = [batteries431CycleFix];
         };
         # System inputs every Lake build/derivation here needs.
         leanBuildInputs = [
           pkgs.gmp
-          pkgs.lean.lean-all
+          lean
           pkgs.rsync
         ];
         lakeBuildArgs = {
@@ -151,7 +146,7 @@
             test -x ${lean4leanCLIRaw}/bin/lean4lean
             mkdir -p $out/bin
             makeWrapper ${lean4leanCLIRaw}/bin/lean4lean $out/bin/lean4lean \
-              --set LEAN_SYSROOT "${pkgs.lean.lean-all}" \
+              --set LEAN_SYSROOT "${lean}" \
               --prefix LEAN_PATH : "${leanPath}"
           '';
 
@@ -250,12 +245,8 @@
           ${lean4leanCLI}/bin/lean4lean > out
         '';
       in {
-        # Lean overlay
         _module.args.pkgs = import nixpkgs {
           inherit system;
-          overlays = [
-            (lean4-nix.readToolchainFile ./lean-toolchain)
-          ];
         };
 
         packages = {
@@ -284,8 +275,8 @@
         };
 
         devShells.default = pkgs.mkShell {
-          packages = with pkgs; [
-            lean.lean-all
+          packages = [
+            lean
           ];
         };
 
diff --git a/lake-manifest.json b/lake-manifest.json
index 3542863a..f18b8d0d 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,10 +5,10 @@
    "type": "git",
    "subDir": null,
    "scope": "",
-   "rev": "fa08db58b30eb033edcdab331bba000827f9f785",
+   "rev": "4488d40d070b9700d4d5a6aa342f0d40c31b2a2d",
    "name": "batteries",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.31.0",
+   "inputRev": "v4.33.0",
    "inherited": false,
    "configFile": "lakefile.toml"}],
  "name": "lean4lean",
diff --git a/lakefile.toml b/lakefile.toml
index f862fab7..c0d82fec 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -4,7 +4,7 @@ defaultTargets = ["Lean4Lean", "lean4lean", "Lean4Lean.Theory", "Lean4Lean.Verif
 [[require]]
 name = "batteries"
 git = "https://github.com/leanprover-community/batteries"
-rev = "v4.31.0"
+rev = "v4.33.0"
 
 [[lean_lib]]
 name = "Lean4Lean"
diff --git a/lean-toolchain b/lean-toolchain
index 18640c8b..025e5954 100644
--- a/lean-toolchain
+++ b/lean-toolchain
@@ -1 +1 @@
-leanprover/lean4:v4.31.0
+leanprover/lean4:v4.33.0
diff --git a/plans/l4l-15-structure-eta-design.md b/plans/l4l-15-structure-eta-design.md
new file mode 100644
index 00000000..6f5f9209
--- /dev/null
+++ b/plans/l4l-15-structure-eta-design.md
@@ -0,0 +1,218 @@
+# L4L-15B registered structure-eta design
+
+Date: 2026-08-11
+
+Status: approved fork divergence; implementation target is the reconciled
+v4.33 base at merge checkpoint `99a7f8ae7b89`. Upstream review is deferred to
+the L4L-20C PR series. This note is the mandatory pre-implementation design
+record for ledger entry D019.
+
+## Scope and kernel behavior
+
+Lean gives eta conversion to nonrecursive, single-constructor inductives with
+no indices. For a checked structure family `S`, constructor `C`, parameters
+`ps`, canonical generated projectors `proj_i`, and a well-typed major `e`, the
+new Theory step is the contraction
+
+```text
+C ps (proj_0 e) ... (proj_n e)  ≡  e : S ps.
+```
+
+The zero-field case is the same rule with an empty projector list. Prop-valued
+structures remain convertible by proof irrelevance as well; using one
+eligibility artifact for Prop and Type keeps host metadata alignment uniform.
+
+The previous derivability audit is unchanged by the v4.33 reconciliation.
+Recursor iota rules reduce a projector only on a constructor-headed major,
+function eta applies only at Pi types, and proof irrelevance covers only Prop.
+Consequently the neutral reconstruction equation above is not derivable from
+the existing `VEnv.IsDefEq` constructors.
+
+## Lower-layer descriptor and registry
+
+`VStructEta` lives below `Typing.Basic`. It contains only Theory syntax and
+the syntactic stability laws needed by generic equality transport:
+
+```text
+structure VStructEta where
+  uvars          : Nat
+  nparams        : Nat
+  nfields        : Nat
+  familyName     : Name
+  familyType     : VExpr
+  constructorName : Name
+  projectors     : List VLevel -> List VExpr -> List VExpr
+
+  projectors_length : levels.length = uvars ->
+    params.length = nparams ->
+    (projectors levels params).length = nfields
+  projectors_liftN : ...
+  projectors_instN : ...
+  projectors_instL : ...
+```
+
+The omitted equations are literal naturality equations: mapping `liftN`, term
+substitution, or universe instantiation over a projector list equals asking
+the descriptor for the correspondingly transformed levels and parameters.
+They are equations about syntax, not semantic equality assumptions.
+
+The descriptor defines, rather than stores as caller-selected callbacks:
+
+```text
+structureType levels params = const familyName levels |>.appN params
+rebuild levels params major =
+  const constructorName levels |>.appN
+    (params ++ (projectors levels params).map (.app . major))
+```
+
+`VEnv` gains a monotone `structEtas : VStructEta -> Prop` registry and an
+`addStructEta` extension operation. `empty` registers none; `addConst` and
+`addDefEq` preserve registrations; `VEnv.LE` transports them. `Ordered` gains
+one constructor whose premise is `VStructEta.WF env`, and
+`Ordered.structEtaWF` recovers that certificate for every registered
+descriptor.
+
+`VStructEta.WF env` is the subject-reduction package. Given a well-formed
+context, well-formed universe arguments of the exact length, an exact family
+parameter `SpineWF`, and `major : structureType levels params`, its
+`rebuild_hasType` field produces the same type for `rebuild levels params
+major`. This package contains no equality premise.
+
+`VStructureView.toStructEta` is the only checked generation bridge used by
+the verifier. It sets `projectors` to the deterministic
+`VStructureView.projectionCodes` projector list. Its naturality laws are the
+existing `projectionCodes_liftN`, `projectionCodes_instN`, and
+`projectionCodes_instL` theorems; its subject-reduction proof is
+`ProgramsWF.etaRebuild_hasType_of_constructorPrefix` plus the registered
+constructor telescope. A `ProjectionArtifact` records membership of this
+exact descriptor, so host readiness cannot substitute arbitrary projector
+syntax.
+
+## Equality rule
+
+The new constructor in `VEnv.IsDefEq` has the following exact logical shape
+(notation abbreviated):
+
+```text
+IsDefEq.structEta
+  (registered : env.structEtas rule)
+  (levelsWF : every level in levels is WF at U)
+  (levelsLength : levels.length = rule.uvars)
+  (paramsLength : params.length = rule.nparams)
+  (paramsSpine : familyType.instL levels consumes params to a sort)
+  (majorTyped : Gamma |- major : rule.structureType levels params)
+  (rebuildTyped : Gamma |- rule.rebuild levels params major :
+    rule.structureType levels params)
+  : Gamma |- rule.rebuild levels params major == major :
+      rule.structureType levels params
+```
+
+Both endpoint typings are deliberately constructor premises. Thus
+`IsDefEq.hasType` and `IsDefEq.isType'` remain structural for arbitrary
+environments; `Ordered.structEtaWF` supplies `rebuildTyped` at registered
+call sites rather than becoming a hidden equality oracle. The parameter spine
+and exact lengths make the primitive unavailable on partial applications.
+
+Weakening and term/universe substitution rebuild the same constructor with
+the descriptor naturality equations. Context-defeq transport preserves the
+syntax and transports the two typing premises. Environment monotonicity uses
+the new `VEnv.LE.structEtas` component.
+
+## Strong typing, inversion, and discrimination
+
+`IsDefEqStrong` gains the same registered step with strong certificates for
+the common structure type and both endpoints. The weak-to-strong translation
+obtains these from the recursive typing premises; strong-to-weak erases them.
+The `HasTypeStrong` inversion family sees the new case only through those
+endpoint certificates.
+
+Sort/Pi/constant-head discrimination does not discard the case by syntactic
+pattern matching. If the arbitrary major has the queried head, its explicit
+typing is compared with the registered `const familyName ... |>.appN params`
+type via the existing strong unique-typing/inversion path. The reconstruction
+endpoint is constructor-headed. This keeps the existing L4L-16/L4L-17
+frontier visible rather than embedding injectivity in the descriptor.
+
+## Confluence and standardization
+
+Structure eta is represented in `NormalEq` by left and right reconstruction
+forms, analogously to function eta. The congruence payload relates the major
+terms and every parameter/projector occurrence at one registered descriptor.
+The descriptor naturality laws provide weakening and substitution directly.
+
+The parallel-reduction compatibility proof must cover these cases explicitly:
+
+1. constructor major versus generated projector iota;
+2. nested reconstruction, contracting either layer first;
+3. beta/delta/iota reduction inside the major and its repeated projector
+   occurrences;
+4. dependent later projector types after an earlier projection changes;
+5. proof fields and Prop-valued structures; and
+6. overlap with a registered `.extra` rule under the generic `[Params]`
+   pattern interface.
+
+No new `sorry`, axiom, or final-result field is added to `Params`. The generic
+development may gain primitive descriptor coverage/disjointness premises,
+but the actual triangle/join statements remain proved theorems. The concrete
+checked-view bridge must discharge those premises from constructor-headed
+syntax and the deterministic projector programs.
+
+`WHRed` does not contract structure eta: as in Lean's equality procedure it
+is a conversion rule, not weak-head computation. Head standardization gains
+only the cases needed to transport the enlarged `NormalEq` relation.
+
+## Exhaustive consumer inventory
+
+Before the rule lands, the direct constructor-aligned source inventory is:
+
+| File | Direct aligned sites | Required work |
+|---|---:|---|
+| `Typing/Basic.lean` | 1 | rule and subject-reduction-facing aliases |
+| `Typing/Lemmas.lean` | 9 | closure, levels, mono, weak/inst/context transport |
+| `Typing/Strong.lean` | 12 | strong relation, translations, inversion |
+| `Typing/NestedTransport.lean` | 1 | nested environment transport |
+| `Typing/ChurchRosser.lean` | 26 | `NormalEq`, parallel joins, CR translation |
+| `Typing/HeadReduction.lean` | 12 | standardization interaction |
+
+The compiler-driven audit also covers dependent consumers in
+`UniqueTyping`, `Injectivity`, `InductiveLemmas`, `Projection`, and Verify.
+Every failed exhaustive match after adding the constructor is treated as an
+inventory defect, not silenced with a wildcard.
+
+Environment-schema consumers are `VEnv`, `Typing.Lemmas` (`Ordered`),
+`Typing.Env`/`EnvLemmas`, Verify's `TrEnv'`/`VEnvAt` construction, and the few
+explicit `VEnv.LE` records in Verify environment extension proofs.
+
+## Checker closure and fixtures
+
+`ProjectionArtifact` and `ProjectionReady` retain the exact registered eta
+descriptor for any host family/constructor accepted by
+`isNonRecStructure`. This supplies both `StructureEtaReady` and descriptor
+membership. `VEnv.HasStructureEta` is then a theorem derived from
+`IsDefEq.structEta`, not a new assumption. The already proved
+`tryEtaStructCore.WF_of_structureEta` and
+`isDefEqUnitLike.WF_of_structureEta` become the bodies of the unconditional
+roots.
+
+Focused executable/Theory fixtures cover:
+
+- a dependent parameterized structure and neutral major;
+- a parameterized zero-field structure;
+- a proof field;
+- a Prop-valued one-constructor inductive; and
+- recursive, multi-constructor, and indexed negative cases.
+
+Exact `#print axioms` guards cover descriptor registration,
+`VStructEta.WF.rebuild_hasType`, the primitive equality step, its
+Church--Rosser translation, and both checker roots. The L4L-15B checkpoint may
+inherit already classified frontier dependencies, but its source diff adds
+no `sorry` and the compiled frontier may not grow.
+
+## Removal and upstream path
+
+D019 is revisited at every upstream reconciliation. It is removed when
+upstream adopts this registered primitive or an agreed equivalent and the
+fork migrates. If upstream ultimately rejects any Theory representation of
+structure eta, the recorded fallback is to disable `tryEtaStruct` and
+`isDefEqUnitLike`; certifying the current runtime against a weaker relation is
+not an option.
diff --git a/plans/l4l-16-completion-plan.md b/plans/l4l-16-completion-plan.md
new file mode 100644
index 00000000..4b7c1cc5
--- /dev/null
+++ b/plans/l4l-16-completion-plan.md
@@ -0,0 +1,993 @@
+# L4L-16 completion plan
+
+Date: 2026-08-13 (audit window 04:50–05:10 EDT)
+Author: fresh audit session (Claude), commissioned because L4L-16 "looks
+stuck or spinning."
+Status: proposal for review. No Experimental/ or roadmap edits were made by
+this session. All measurements below were taken against the live working
+copy and its freshly rebuilt oleans; the working copy is a **moving
+target** (see §1.0), so line numbers are approximate by ±20.
+
+## 0. TL;DR
+
+L4L-16 is much closer to done than the roadmap's tone suggests, and the
+spinning has an identifiable root cause. The measured critical path to the
+gate theorem is **one file-local sorry** (the adequacy iota leaf, which
+decomposes into three named obligations O1–O3, §3) **plus one `SExpr.lean`
+lemma** (`WHRedS.defeq`, consumed by the leaf machinery via dot-notation —
+the only one of the nine SExpr sorries on the gate path). Of the other
+eight, two are false as stated, and one (`CRDefEq.trans`) is a disguised
+port of all of L4L-18A. The fix is a milestone re-cut: narrow L4L-16B to
+what the gate consumes, resolve the leaf by an explicit interface decision
+instead of a sixth transport-infrastructure repair, move the
+Church–Rosser-shaped debt into L4L-18A where it belongs, and stage
+L4L-16D (the only never-executed segment). Two of L4L-17's four targets
+land free when the leaf closes; L4L-17 re-scopes to reflection +
+`weakN_iff` + structure-head inversion. The live worker has already begun
+the recommended leaf repair (the `PatternLeafSpine.aligned` refactor) —
+this plan endorses completing it, with the endpoint pinned in advance.
+
+## 1. Measured state (evidence, not narrative)
+
+### 1.0 Operational context
+
+- Two other AI sessions have this checkout as cwd: a codex session on
+  pts/3 (running since Aug 10, ~50 h CPU) and a Claude session on pts/11
+  (since Aug 12). One of them was still editing
+  `ShapeLogRel.lean`/`ShapeLogRelAdequacy.lean` at 05:02 and rebuilding at
+  05:03 during this audit. The Claude peer `navigatrix-1b` explicitly does
+  **not** work in this repo (confirmed by direct message).
+- The uncommitted working copy is one 18h+ mega-change on top of the
+  L4L-18B checkpoint (`oluxtqyk`/`96aeab5c`), mixing: completed L4L-16A,
+  partial 16B, near-complete 16C, four file parkings, and ~300 lines of
+  roadmap narrative. During the audit window `SExpr.lean` was briefly
+  red (a `WithLift.defeq` projection error) and was fixed at 04:56 —
+  i.e. the working copy has been oscillating red/green.
+
+### 1.1 The gate path is one sorry wide
+
+Measured with `#print axioms` against the 05:03 oleans:
+
+| Declaration | Closure |
+|---|---|
+| `VEnv.IsDefEqU.sort_invS` (the L4L-16 endpoint) | `[propext, sorryAx, Classical.choice, Quot.sound]` — **no project axiom** |
+| `SExpr.LR.adequacy` | same |
+| `SExpr.LE_Interp.sound` | `[propext, Classical.choice, Quot.sound]` — clean |
+| `VEnv.IsDefEqStrong.mkS` (judgment translation incl. structEta) | `[propext, Quot.sound]` — clean |
+| `SExpr.LRS.CtorDefEq.fold`, `SExpr.LR.DefEq.ctor'_inv` | clean |
+| `SExpr.forallE_inv`, `SExpr.sort_forallE_inv` | sorryAx **only via the leaf** |
+
+The `sorryAx` sources on the route are exactly two:
+
+1. the adequacy leaf (`ShapeLogRelAdequacy.lean:~1228`, the body of
+   `LR.PatternLeafDefEq.of_iota`'s `by` block inside `LR.adequacy`'s
+   const case, downstream of the proved `ctor'_inv`), and
+2. `SExpr.WHRedS.defeq` (SExpr.lean:~2920), consumed **via dot-notation**
+   (`hredX.defeq`, `hMajorX.defeq`) at ≥6 sites in the adequacy file
+   (495/496/507/518 inside the proved `LR.iotaActions_of_exactAt`, plus
+   839, 1125). A literal-name grep misses these — which is how one audit
+   pass wrongly concluded no SExpr sorry is on the path.
+
+The other eight `SExpr.lean` sorries are not referenced by
+`ShapeLogRel.lean` or `ShapeLogRelAdequacy.lean`.
+
+Bonus: `SExpr.forallE_inv` and `SExpr.sort_forallE_inv` already exist and
+are sorry-free **except through the leaf** — closing the leaf delivers the
+SExpr side of two L4L-17 targets simultaneously.
+
+### 1.2 The L4L-16B list is mis-scoped
+
+Current live `SExpr.lean` sorries (9), triaged:
+
+| # | Decl (≈line) | Verdict |
+|---|---|---|
+| S1 | `IsDefEqLift.subst` (2655) | **False as stated** — `HasType` is a free section variable, so the premise admits the trivial relation. The sound weak form `substDefEq` (2648) is already proved. Restate with a `:↑`-valued `Ctx.Subst` or **delete** if no consumer needs the lifted conclusion. |
+| S2 | `WHRed.weakU_inv` `.extra` (2796) | Real but bounded: needs lowering of `Pattern.Action`'s two `IsDefEq` fields; match-lowering (`matchesS_lift'`) already proved. Route: restate `Action`'s `checked`/`sound` at `:↑`, which also subsumes S1's consumer. (2026-08-15: NOT deletable — `WHRedS.weakU_inv` is live via `InferType.weakU_inv`'s cases and `Experimental/LogRel.lean:210`; consumers now named in its doc comment.) |
+| S3 | `WHRedS.defeq` (2919) | **On the gate path now** (2026-08-15 re-measure: 11 live call sites, reduced to 3 — all on the adequacy trunk (`constDefEq`, `SelfAdequateConstStep.of_steps`, `adequacy_of_iotaWitnessStep`) — after the dead-wrapper deletions; original note said 6 dot-notation sites, §1.1). As stated it needs a weak-`IsDefEq` typing-inversion layer (`isType`, `app_inv`, `lam_inv`…) that does not exist SExpr-side and is uniqueness-strength — see §2.3 circularity. Do not prove as stated; close via the narrowed form in §3 (16C′ step 2). |
+| S4/S5 | `InferType.hasType`/`InferTypeS.hasType` (3017/3097) | **DELETED 2026-08-15** (zero consumers repo-wide; the adequacy development consumes neither `▷` nor `▷*`). |
+| S6 | `CRDefEq.trans` (3239) | **A whole-module port in disguise**: needs `CParRed`, `ParRed.triangle`, `ParRed.church_rosser`, `NormalEq.trans`, `NormalEq.parRed` — the last is itself the open L4L-18A Theory debt. Move out of L4L-16 entirely. |
+| S7–S9 | `InferType.whRed` cases (3263–3269) | **Statement wrong** (`▷` is syntactic; no conversion rule; all three cases unprovable as written). Restate (`▷*`/up-to-defeq) or delete; no Theory analogue exists. |
+
+Also stale in the roadmap: `Shape.WF.plift`'s "hidden `stop` admission"
+does not exist — lines ~1687–1754 of `ShapeLogRel.lean` are a block
+comment with zero consumers, and the file is **live-sorry-free**. The
+architectural replacement (`CtorDefEq.lift/unlift` + `LogRel.LiftEquiv`)
+is already in place and proved. Delete the commented block and strike the
+ledger item. (Also: `Params.Semantic` now has six fields, not five —
+`iotaRule` is undocumented.)
+
+### 1.3 L4L-16D is genuinely at zero, with enumerated gaps
+
+No `Params` or `Params.Semantic` instance exists anywhere. Known gaps for
+a live instance:
+
+- SExpr `Params`: `classify`, `Pat`, `pat_wf`, and the six combinatorial
+  laws must be sourced from block certificates; `AssembledPat` currently
+  supplies only `pat_simple` and `ext_covers` — the four uniqueness/
+  non-overlap laws exist only block-locally (`IotaPat.*`) and there is no
+  cross-term (block-rule vs extension-rule) non-overlap lemma.
+- SExpr `Params.Semantic`: six fields (`structureEta`, `ctor`, `defn`,
+  `iotaRule`, `iotaSite`, `registered`) to be populated from the L4L-15B
+  eta registry, generation certificates, declaration history, and
+  D020 beta-collapsed coverage respectively.
+- Theory-side `Params`/`Params.Extension.join` (consumed only by
+  `IsDefEq.church_rosser`) additionally needs four structEta/forallE
+  inversion fields with **no current supplier** — weakN-inversion-strength
+  facts, i.e. L4L-17 territory. It is NOT needed for `sort_inv`.
+
+### 1.4 Theory frontier interaction
+
+`IsDefEq.uniq` consumes exactly `sort_inv` (×9) and
+`forallE_inv_stratified` (×1); nothing else on the Tier-R list. So the
+semantic route, once reflected, unlocks the entire transitional
+unique-typing closure — which is what `pat_wf` and the projection
+consumers shed `sorryAx` on.
+
+## 2. Root-cause of the spinning
+
+1. **The leaf is a design decision being treated as a lemma.** The
+   working-copy roadmap records five successive infrastructure repairs at
+   the leaf (`iotaSite` contract, `SpineDefEq`, `LiftEquiv`,
+   `PatternLeafSpine`, `CtorDefEq` fold audit), each ending in the same
+   discovery: exact constructor observations erase the SExpr type of
+   their midpoint/captures, and no amount of transport machinery can
+   re-manufacture it. The roadmap itself names the two exits (carry the
+   canonical type as data, or promote a limited uniqueness lemma) — and
+   the sessions kept building a third thing instead.
+2. **A mis-drawn milestone boundary legitimized off-path work.**
+   "L4L-16B = close all SExpr admissions" put two false statements, one
+   L4L-18A-sized port, and several gate-irrelevant lemmas on the active
+   list. Effort flowed to what was listed, not to what the exit consumes.
+3. **A latent circularity in the repair machinery.** The already-proved
+   leaf machinery (`iotaActions_of_exactAt` and friends) routes typing
+   through the sorried `WHRedS.defeq`, whose honest generic proof needs
+   weak-judgment typing inversion — the very uniqueness-strength
+   frontier this development exists to prove. Theory "solves" this only
+   inside its transitional (sorry-bearing) closure. Any repair that
+   keeps the generic dependency re-imports the problem. The way out is
+   that every call site has stronger evidence in scope than the generic
+   lemma assumes (carried `Action.sound` equalities, full `SpineWF`
+   certificates), so a certificate-carrying variant suffices — see
+   §3 16C′ "S3-narrow".
+4. **Process:** 18+ hours of uncommitted mega-change, red↔green
+   oscillation, roadmap-as-lab-notebook, and (this morning) two sessions
+   plus an auditor in the same working copy. The ladder's own
+   one-auditable-claim-per-checkpoint rule has been suspended in practice.
+
+## 3. The re-cut
+
+Principle: **L4L-16's exit is the promotion of `sort_inv` at the accepted
+closure. Everything not consumed by that path moves to the milestone that
+consumes it.**
+
+### L4L-16B′ — SExpr infrastructure, narrowed
+
+Keep only:
+- S2 via the `Pattern.Action`-at-`:↑` restatement (also settles S1's
+  consumer question).
+- S1: restate-or-delete (decide by grepping consumers; expected: delete).
+- S7–S9: restate `InferType.whRed` with a `▷*`/up-to-defeq conclusion or
+  delete (no consumer found).
+- Delete the commented `Shape.WF.plift` block; correct the roadmap claims
+  (§1.2).
+
+Explicitly move out:
+- S6 `CRDefEq.trans` → L4L-18A′ (it IS Church–Rosser).
+- S3/S4/S5 → deferred until §3's leaf decision determines whether any
+  accumulator-typing fact is needed at all, and in what judgment (see
+  next).
+
+### L4L-16C′ — close the leaf by decision, not accretion
+
+The leaf (`~1228`) decomposes into three named obligations (per the
+2026-08-13 audit; details in the audit agent's map):
+
+- **O1 — a composable fold motive over `LRS.CtorDefEq`.** The blocker.
+  `CtorDefEq.exact` hides its head/result types (`CHead, CHead', A, A'`)
+  existentially, so the `.trans` handler of any `CtorDefEq.fold` has a
+  shared midpoint `N` with **no exportable typing**. Fix (Option A,
+  recommended, **already begun by the live worker** — the
+  `PatternLeafSpine.recArgs → aligned : LRS.CtorSpineDefEq` refactor):
+  restate `.exact` to carry `LRS.CtorSpineDefEq` — which already shares
+  **one** result type `A` and one domain `D` per field — and give
+  `CtorSpineDefEq` a `trans`. That `trans` does NOT need general
+  uniqueness: `SpineWF`/`SpineDefEq` conversion steps each **carry**
+  their defeq certificate, and the constructor's head type is pinned
+  **syntactically** as a Pi telescope by the live certificate
+  (`CtorBundle.rhs` is literally `Ts.foldr .forallE …`, supplied by
+  `Params.Semantic.ctor` into `IsDefEqStrong.const`'s `F`/`hF` fields).
+  So the midpoint alignment composes from carried conversions plus the
+  certificate telescope — nothing is manufactured. Update the two
+  construction sites (`constDefEq` ctor case ~961; nullary case ~1264)
+  and the `Algebra`/`fold` handlers.
+  **Option B (fallback only):** the scoped alignment lemma
+  "`SpineWF Γ CHead args.reverse A → SpineWF Γ CHead args.reverse A' →
+  ∃ u, Γ ⊢ A ≡ A' : .sort u` for a certificate-pinned head" — L4L-17
+  content promoted into 16C. Try it only if A's encoding change
+  explodes.
+- **O2 — mechanical glue.** With O1's `.exact` handler,
+  `LRS.iotaDefEq_of_exactAt` (proved, currently unconsumed) is a direct
+  fit; all its remaining inputs are already in scope at the sorry.
+- **O3 — `LRS.IotaRHSDefEq`, the one genuinely new proof.** Reduce via
+  `of_nonbot` (proved); variable-RHS leaves are discharged by the
+  supplied `CaptureDefEqAligned` family (already type-aligned — no
+  uniqueness needed). The remaining fixed-tower head case is to be
+  proved by **well-founded recursion on the semantic `R`-edges via
+  `LE_Interp.recR`** (the design comment at the `IotaRHSDefEq` def says
+  exactly this), then the application chain closes by `LRS.DefEq.app`.
+  No environment or reduction oracle.
+
+Plus **S3 (revised 2026-08-13 after reading the site contracts —
+supersedes "S3-narrow")**: the four live `.defeq` call sites reduce to
+two facts about the ROOT pair only — the spine-redex self-typing at the
+package `A` (from `htermX` plus major-position congruence) and
+`IotaTyping.majorEq` (the typed collapse `majorX ≡ ctorSpine :
+majorType`). Neither can be discharged by a certificate-carrying
+variant alone: the major's stored reduction is an arbitrary weak-head
+sequence, and per-step subject reduction hits beta/extra cases needing
+typing inversion. The honest route is the one the `▷` layer was built
+for — the **InferType principal-types bootstrap**: syntactic
+`InferType.determ` (already proved) substitutes for type uniqueness;
+prove inference completeness over `IsDefEq` (each case computes the
+principal type and connects it to the derivation's type by the IH, no
+uniqueness needed), restate `InferType.whRed` up-to-defeq (the false
+exact-form was deleted at 16B′), restore `InferType.subst`/`inst` with
+a `:↑`-valued substitution premise, and derive the needed `⤳* → ≡`
+conversions from principal-type subject reduction. S4/S5 close en route.
+This is a real sub-development (days), and it is confined to the ROOT
+pair: intermediate chain links never need it (see the chain addendum).
+
+Note on `hDef`: the "circular constant premise" is a field of
+`IsDefEqStrong.const` discharged by `mkS` out of
+`Params.Semantic.defn` — it needs **no separate 16C work**; its
+live-environment construction is exactly 16D's `defn` field.
+
+Rule: if the chosen option hits a second wall, STOP and re-derive the
+mathematical obligation in this file before writing more Lean. No sixth
+transport layer.
+
+**O1 design addendum (2026-08-13, recorded before implementation).**
+Deriving the fold motive abstractly hit the two-strikes rule: every
+variant that runs the typed iota-site construction at *intermediate*
+fold nodes (trans midpoints, or exact nodes reached inside the free
+closure) terminates at the same irreducible brick — reconciling two weak
+typings of one term (midpoint, or reduct spine) without inversion, which
+is the uniqueness-strength frontier itself. `Pattern.Action` sites for
+intermediate pairs are therefore impossible by design, not by missing
+lemmas: the free closure's midpoints are genuinely untyped up to
+weak-head expansion (`LogRel.whr` is deliberately an untyped iff).
+Decided architecture — **root-anchored capture-chain fold**:
+
+- The fold motive carries NO typing and NO sites: only (i) each
+  endpoint's weak-head reduction to its constructor spine, and (ii)
+  composable per-field semantic relations (`IH`-level) between the two
+  spines' fields, plus the head/level agreement.
+- `trans` composes via weak-head determinism (`WHRedS.inferType`
+  uniqueness: the shared midpoint's two constructor-spine reducts are
+  syntactically equal, so field columns literally coincide) and the
+  relation's PER laws; `whr`/`unwhr` via `WHRedS.determ_l`; `mono` via
+  `mono_l`; `lift`/`unlift` via the carried `LiftEquiv` fields; `left`/
+  `symm` via the PER laws.
+- The typed layer (both `Pattern.IotaTyping` sites, the `Action`s, the
+  `PathSpineWF` capture spines) is built ONCE, at the root pair, where
+  the `PatternLeafSpine` package supplies every typing; the fold's
+  output supplies the root-to-root capture relations that
+  `IotaRHSDefEq` consumes.
+
+Implementation status (2026-08-13, checkpoint `wolxmups`): the
+syntactic midpoint-agreement layer is kernel-checked in `SExpr.lean` —
+`Pattern.WF.arity_head`, `spine_inj`, `Params.matchesS_symb_head`,
+`WHNF.ctorSpine`, `WHRedS.ctorSpine_eq`, and `WHRedS.ctorSpine_determ`
+(two weak-head reductions of one term onto classified constructor
+spines land on the same syntactic spine). Remaining chain work, in
+order: (1) define `LRS.CtorLink`/`LRS.CtorChain` (links = `.exact`
+field bundles between adjacent spines; concatenation via
+`ctorSpine_determ`); (2) `CtorDefEq.toChain` by induction on the free
+closure — `left`/`symm` need the link mirror (either add the
+right-anchored aligned spine to `.exact`, free at both construction
+sites since they pass the same head twice, or re-anchor
+semantically); `whr`/`unwhr` via `WHRedS.determ_l`; the open
+sub-design is `mono`/`lift`/`unlift` bookkeeping — per-field
+`HasType` side conditions for `mono_l` must travel in the links
+(`CtorSpineDefEq.cons` already stores `hp`), and cross-level moves
+compose stored `LiftEquiv`s; if a zigzag resists `trans`/`cancelRight`
+reduction, keep links at their native levels and let the consumer
+rebase, since links carry their own `HasType`s. Sharpened at the mirror
+checkpoint: pointwise lowering of a spine at lifted element-shapes is
+NOT derivable — the cons-step's type-shape `a` is existentially bound
+and need not be a lift even when the element-shape is, so the
+`hliftTy`/`hlift` iffs don't apply; the chain must therefore either
+carry per-link native levels with an explicit connection to the root
+relation (the LiftEquiv-zigzag question), or the link's semantic
+payload must be re-derived from its raw payload at consumption time.
+Decide this before writing `toChain`.
+
+**Chain-level design closure (2026-08-13, second autonomous tick).**
+The `HasTypeU` inversion characterization settles the lowering
+question: for `sort`/`ctor`/`indTy`/`forallE` element-shapes the
+type-shape is forced to a lift-stable form (`.type`, `.indTy`,
+`.sort r`), so those cons-steps lower through the node iffs after a
+`mono_r_2` canonicalization; but a `lam`-shaped field's type-shape is
+an arbitrary Pi-shape, no lift-shaped Pi-shape sits below it except
+payload-destroying bot-forms, and pointwise lowering is therefore
+impossible exactly where the rejected `Shape.WF.plift` said it would
+be. Consequently per-link *semantic* payload cannot be transported to
+the root level in general, and per-link processing at foreign levels
+is out. The forced design: links glue at the RAW layer. Adjacent links
+share their middle spine syntactically (`ctorSpine_determ`), so
+cross-link field alignment reduces to aligning the two links' raw
+telescopes at that shared spine, which descends from one fact —
+
+**Lemma (C), weak constant-type coherence:** any derivation of
+`Γ ⊢ .const c ls₀ ≡ .const c ls₀ : T` (more precisely: any
+`IsDefEq` derivation whose endpoint is the constant) has
+`T` raw-defeq-connected to `mkInst ls₀ ci.type`. Provable by direct
+structural induction on the weak judgment — constant-headedness is
+preserved or vacuous in every case, `defeqDF` extends the chain,
+`proofIrrel` recurses into its typing premise — EXCEPT the `.extra`
+case, where a registered equation whose instantiated lhs is the bare
+constant would type it at the equation's type. Bare `[Params]` does
+not link `env.defeqs` to `classify`, so (C) needs one new coherence
+field (natural home: `Params.Semantic`, alongside `registered`):
+*the stripped lhs head of every registered equation classifies as a
+symbol* — i.e. ctor-classified constants are never definition heads.
+The 16D instance discharges it from the same pattern-coherence that
+already gives `pat_wf`. With (C), the shared-middle composition gets
+its raw domain alignment (`A₁ ≡ A₁'` telescopewise from
+`CHead'ᵢ ≡ CHeadᵢ₊₁` by descending both spines' carried `hPi`
+conversions), and the root-level field relations compose via the
+per-shape semantic argument (sort/indTy/bot free; lam via the aligned
+raw premise).
+
+**Composition impossibility map and staged resolution (2026-08-13,
+same tick — RECOMMENDED DECISION, flagged for John's review).**
+Checking `IsDefEq.trans'` closed the last free route: it is
+sort-level-heterogeneous only, not general. The complete map: raw
+cross-type composition needs general heterogeneous transitivity (=
+weak type uniqueness, L4L-17); semantic composition at `lam`-shaped
+fields needs the same rule inside `LamDefEq`'s raw argument premises;
+per-link typed sites need it to retype intermediate spines; and (C)'s
+telescope descent needs Pi-injectivity (Tier R). Every route
+terminates at the same missing rule *for higher-order constructor
+fields specifically*; first-order fields (`sort`/`ctor`/`indTy`/`bot`
+shapes) compose by per-shape arguments that are all available today
+(`LR0` type-obliviousness at the base; `IndTyHead` from target
+validity; free `CtorDefEq.trans` one level down for `ctor`-shaped
+fields, eliminated recursively).
+
+**Joint-induction design, first pass (2026-08-13, third autonomous
+tick).** Two candidate structures examined and one selected as the
+working hypothesis:
+
+- *Dead end recorded:* the naive co-proved statement — level-indexed
+  raw domain interchange (`U_n`: two Pi-typings of a shared related
+  term have raw-defeq domains, derived from adequacy at level `n`) —
+  is not derivable from adequacy at any level, because adequacy's
+  outputs are semantic relation facts while the lam-field composition
+  consumes a *raw* retyping of arguments (`LamDefEq`'s raw premise).
+  No relation-level strengthening fixes this without either stripping
+  the raw premise (which the fundamental lemma's lam case needs) or
+  smuggling in the full uniqueness frontier.
+- *Working hypothesis — the principal-type discipline:* InferType
+  completeness ("every weak derivation types its subject at a type
+  raw-defeq-chain-connected to the syntactic principal type, with the
+  chain constructed by the completeness induction itself, not by
+  uniqueness") plus the already-proved syntactic `InferType.determ`
+  gives shared-term type agreement *by determinism*: two typings of a
+  shared term both chain to the SAME principal type, so their
+  connection composes through it (`trans'` applies — every chain step
+  is sort-typed). The open verification questions, in order: (q1) does
+  completeness actually close over this judgment's 15 cases without
+  uniqueness — the `extra` case consumes the registered equation's
+  type, the `proofIrrel` case recurses into its typing premise, and
+  `beta` needs the restored `:↑`-premised `InferType.subst`; (q2) the
+  chains' sort-typed steps must convert relation facts along them
+  (relation `conv` needs semantic `TyDefEq`, so each chain step's raw
+  defeq must pass through adequacy or a direct semantic-validity
+  argument — candidate: the chain steps are `defeqDF` side conditions
+  that the completeness induction can emit in semantic form too);
+  (q3) whether Pi-domain extraction from a chain still needs
+  injectivity, or whether anchoring relation facts at principal types
+  BEFORE unfolding to Pi-forms avoids the extraction entirely
+  (determinism gives one shared Pi-form).
+
+Consequence — dependency inversion: the InferType bootstrap (S3,
+task 4) moves AHEAD of the joint-induction finalization; the design
+completes against what completeness actually yields. Implementation
+order for the bootstrap: (b1) the `:↑`-valued `Ctx.Subst` interface
+and restored `InferType.subst`/`inst`; (b2) `InferType.whRed`
+up-to-defeq; (b3) completeness; (b4) the derived `⤳* → ≡` conversions
+at the root sites; then (q2)/(q3) settle the joint induction's final
+statements.
+
+**DECIDED 2026-08-13 (John): the joint L4L-16/17 route** — see the
+second resolution in `plans/l4l-16-sort-inversion-decision.md`. The
+staging recommendation below is retained for the record but
+superseded: instead of restricting to first-order fields, the
+milestone co-proves a level-indexed limited uniqueness with adequacy
+in one mutual induction (uniqueness at level n from adequacy at level
+n, consumed by the lam-field composition at level n+1), and L4L-17's
+statements become co-deliverables. Route-independent work (chain
+normalization, InferType bootstrap, O3, 16D ladder) proceeds
+unchanged.
+
+**Implementation checkpoint (2026-08-13, joint route):** the working
+tree now contains the kernel-checked joint interfaces
+`LR.AdequacyAt`/`LR.JointStage`/`LR.JointBuilder` and
+`LogRel.LimitedUniq`. A subsequent premise audit rejected the first,
+same-level builder: `AdequacyAt Γ n` alone cannot imply weak-judgment
+uniqueness in an arbitrary context, particularly at bottom shapes. The
+replacement records target-context well-formedness and the actual offset
+bootstrap: adequacy at 0, specialized adequacy at 1, level-0 uniqueness from
+the positive observations, then uniqueness at n consumed by adequacy at
+n+2 and used to derive uniqueness at n+1. The SExpr inversions are
+parameterized by positive-level `AdequacyAt`. The reflection decision is
+also implemented:
+`SExpr.mk` is conservative modulo `VEnv.EqUpToLevels`, reflecting
+semantic-level equality to `VLevel` equivalence and relating every
+well-formed expression to `reify (mk e)`.
+
+The route-independent chain normalization is kernel-checked too.
+`CtorExact` stores one finite native leaf; `CtorFrame` retains all
+`mono`/`lift`/`unlift` transport back to the root without attempting the
+invalid pointwise lowering of high-level fields; `CtorLink` combines
+those two pieces; a nonempty `CtorPath` removes free transitivity; and
+root `CtorView`s isolate weak-head expansion. `CtorDefEq.toChain`
+handles all nine constructors, uses `WHRedS.ctorSpine_determ` at shared
+midpoints, and `CtorChain.toCtorDefEq` proves the round trip. Its
+`CtorChain.Algebra` elimination boundary has only native exact leaves,
+composition, and root anchoring; the original nine-way closure is absent
+from consumers. `CtorChain.NativeAlgebra` further pins the crucial order:
+finish a native exact leaf, fold the completed result through its
+`CtorFrame`, and compose only after reaching the root. This resolves the
+lift/unlift uniqueness question without projecting high-level fields or
+requiring uniqueness for a foreign native relation. The active joint
+dependency is therefore `uniqSucc` plus the deep-`R` iota leaf: the
+specialized level-one bootstrap now derives contextual raw uniqueness and
+the uniqueness-aware chain consumer through path-valued stratified inversion.
+There is no longer an `invZero` field or an unsound generic
+`uniqOfAdequacy` obligation.
+
+**InferType q1 resolution (2026-08-13): negative for the generic
+proposal.** `InferType.app` can be constructed only after the inferred
+function type weak-head reduces to a Pi. An `IsDefEq.defeqDF` conversion
+connects that type to a Pi only by definitional equality; turning this into
+the required reduction is precisely a Church–Rosser/inversion theorem, not
+something inference completeness can emit by structural induction. The
+same obstruction remains at the four root reduction conversions even with
+the existing `SpineWF` packages, because their weak-head paths may contain
+beta and registered steps under an arbitrary converted type. Do not restore
+the deleted generic `InferType.subst`/completeness route. Under the combined
+L4L-16/17 scope, implement the promised limited uniqueness and consume it
+while folding the normalized constructor chain; only then restate the root
+subject-reduction lemma at the exact semantic package it needs.
+
+Superseded recommendation (α): stage the claim. Add a first-order-fields
+restriction at the observation-consumption boundary (an explicit
+`Params.Semantic`-level or shape-level side condition), close the
+L4L-16 leaf and `sort_invS` for first-order-constructor environments —
+which covers the entire D0–D2 fixture ladder (Nat, List, both tree
+blocks; `Acc` is the known exception, entering only at kernel-parity
+scope) — and lift the restriction at L4L-17 when
+`forallE_inv`/uniqueness arrive, exactly as `pat_wf` sheds its
+transitional closure. This matches roadmap §4.5 (staging is monotone
+and temporary) and §2.2's "growing subset" posture. The alternative —
+promoting general weak uniqueness into L4L-16 — was already rejected
+by the route decision (it is Route 2's circularity). Before
+implementing: confirm the restriction's exact carrier (a `WShape`
+first-order predicate on ctor field shapes is the least invasive) and
+record it in the ladder as an explicit stage predicate with a
+rejection fixture.
+
+Execution order for `toChain` is therefore: (a) decide/record the
+first-order stage predicate; (b) `CtorLink`/`CtorChain` at the root
+relation with raw-glued links; (c) `toChain`; (d) the first-order
+composition lemma; (e) lemma (C) and the coherence field only if the
+first-order composition still needs raw telescope alignment (it may
+not: with first-order shapes the semantic layer composes without raw
+support). (3) per-link
+consumption: each link certifies its own iota contraction pair with
+conclusions glued by `(LRS IH).trans` at the package-fixed result type,
+with the root endpoints attached by `whr`-expansion.
+
+Verification condition checked before implementation: the per-field
+composition step needs `IH.DefEq x y D p a` and `IH.DefEq y z D' p a`
+(same syntactic `y`, same shapes, two validity types) to compose.
+**Superseded conclusion (rejected by the lambda case):** the
+concrete relation is type-independent modulo validity — at `.sort`
+type-shapes `DefEq` ignores its type argument entirely, at `.indTy` the
+only type-dependence is the `IndTyHead` conjunct (supplied by the target
+type's own validity), and at `.forallE` every consumed component
+(domain reduction, domain validity, `PiDefEq`, `LamDefEq`) is carried
+inside the definition. Therefore a `Retype` law — `R.TyDefEq A' A' a →
+R.DefEq M N A m a → R.DefEq M N A' m a` — is provable with no new
+assumptions: trivially at `LR0` (its `DefEq` never inspects the type),
+by shape-case analysis with recursion into the lower level at `LRS`,
+hence at `LR` for every level. With `Retype`, cross-observation field
+composition would be `retype` + `IH.trans`.
+
+**Correction (2026-08-13):** `LRS.DefEq` at a lambda observation retains
+codomain validity tied to the original Pi typing, so the assumption-free
+`Retype` claim is false. The implemented builder boundary is
+`RawTypeUniq + LimitedUniq.LamRetype`: raw uniqueness aligns ordinary result
+types, and the term-indexed `LamRetype` callback supplies exactly the
+successor-level lambda case; all other shapes are structural. `PiTypeAlign`
+is retained only as an optional sufficient adapter, because arbitrary valid
+Pi observations need not be compatible. This is packaged by
+`LRS.limitedUniq_of_typeUniq`; the offset `LR.JointBuilder.succ` now also
+receives lower-level adequacy explicitly, matching the actual fixed-head
+recursion dependency.
+
+The normalized-chain audit then exposed a separate raw invariant:
+constructor leaves previously allowed unrelated universe-level lists on
+their two heads. Both producers already use the same semantic list, so
+`CtorDefEq.exact`/`CtorExact.intro` now record `ls = ls'`. Consequently each
+native leaf has an existential ordinary typed equality. The kernel-checked
+`CtorPath.foldRaw` threads one recursor domain across all native links using
+`RawTypeUniq`; `CtorChain.foldRaw` and `CtorDefEq.foldRaw` expose the two root
+weak-head views as explicit typed callbacks. All these theorems measure at
+`[propext, Classical.choice, Quot.sound]`. This proves that intermediate
+links need no subject reduction; only the two roots do.
+
+**Native/root consumer correction (2026-08-13).** The normalized
+`NativeAlgebra` order remains valid, but it does not by itself close iota.
+An exact handler runs at the native relation stored by a link, whereas the
+recursor prefix, result functions, and final type relation are available at
+the canonical root relation. A lift/unlift zigzag relates arbitrary high
+extensions of a common low relation only on shapes lifted from that low
+relation; it cannot project the root prefix into an unrelated native
+refinement. Constant evaluation now returns `LogRel.DefEqRect` (left endpoint
+self-relation, right endpoint self-relation, and cross-relation) so these
+three observations remain synchronized through term-indexed retyping. The
+remaining iota consumer must therefore prove the generated fixed-head
+application chain at the canonical root and use native normalization only for
+the raw constructor/capture boundary.
+
+Finally, O3 is not route-independent as previously stated. The current
+`IotaRHSDefEq` proposition describes the desired result, but
+`PathSpineWF` plus capture alignment does not itself supply logical validity
+for the fixed RHS head or the intermediate semantic Pi telescope. Its
+constructor must live inside a strengthened `LE_Interp.recR` induction and
+receive that head adequacy hypothesis explicitly. The head's syntactic
+self-typing is now kernel-checked independently:
+`Params.Semantic.closedHasTypeStrong` reifies the semantic levels and
+translates the ordered-environment strong typing, and
+`Pattern.IotaRule.rhsStrong` packages the registered RHS specialization.
+
+**Heterogeneous-rule correction (2026-08-13).** The earlier principal-chain
+notes above still assumed that sort-typed chain edges could be collapsed by
+the primitive `IsDefEq.trans'`. That constructor has now been eliminated
+from both weak and strong SExpr judgments. Conversion-aware spines use
+structural concatenation, while successor Pi type validity stores
+`TypeDefEqPath`, a nonempty sequence of ordinary typed equalities. Semantic
+transitivity therefore remains assumption-free; collapsing a path to one raw
+equality consumes `RawTypeUniq` explicitly. The contextual form is packaged
+by `LogRel.ContextualRawTypeUniq` and `LR.ContextualJointBuilder`; the
+level-indexed Pi inversion returns paths, and its `_collapsed` adapter uses
+context well-formedness to collapse the codomain path under the extended
+binder. This supersedes every earlier recommendation that used `trans'` as a
+free composition rule.
+
+**Contextual/recursion correction (2026-08-13).** A compiled skeleton of the
+promised outer `LE_Interp.recR` / inner strong-derivation induction showed
+that shallow `RChildren` evidence is lost in `symm` and the second half of
+`trans`: semantic soundness transports the interpretation, not the recursive
+provenance attached to its proof. The replacement
+`LE_Interp.RDeepChildren`/`recRDeep` traverses ordinary semantic children and
+grants the recursive predicate only at abstract constant edges, which is the
+well-founded interface needed by an inner stratified self-typing induction.
+That induction made the target-context dependency executable rather than
+documentary: Pi uniqueness immediately enters `A :: Γ`, so a wrapper that
+returns already-built fixed-context `JointBuilder Γ`s is circular.
+`JointStage` and `JointBuilder` now quantify over all well-formed target
+contexts at each level, and `HasTypeStratifiedS.forallE_inv` preserves the
+strictly smaller typing depth at the binder boundary. All three additions
+kernel-check and have the standard clean axiom closure.
+
+**Bootstrap/root-closure checkpoint (2026-08-13).**
+`JointStratifiedInversion` now states precisely the stratified sort/Pi facts
+needed by the syntactic proof, and
+`IsDefEq.uniq_of_stratified_inversion` proves contextual weak type uniqueness
+by well-founded induction on maximum typing depth. The full application,
+lambda, Pi, and conversion cases are kernel-checked at
+`[propext, Classical.choice, Quot.sound]`. The initially exposed base boundary
+has now been discharged without assuming its result: positive adequacy
+propagates non-bottom sort/Pi observations across whole heterogeneous
+`TypeDefEqPath`s, proves path-level sort/Pi inversion and stratified path
+uniqueness, and only then collapses the paths. Thus
+`LogRel.contextualRawTypeUniq_of_adequacy` and
+`JointStratifiedInversion.of_adequacy` are kernel-checked, while the redundant
+`JointBuilder.invZero` field has been deleted.
+
+The same package now proves `WHRed.defeq_of_stratified_inversion` and
+`WHRedS.defeq_of_stratified_inversion`, including beta and registered-rule
+steps. `LRS.CtorDefEq.foldRaw_of_jointBuilder` feeds those exact two root
+callbacks and the derived raw uniqueness into the normalized constructor
+chain. Thus the conditional chain/root part of 16C′ is complete and clean;
+the exact lambda-retyping boundary and its lower-adequacy dependency are now
+implemented. The remaining proof body is the canonical-root, deep-`R`
+fixed-head application chain needed at the iota leaf.
+
+**Proof-relevant semantic-recursion correction (2026-08-13).** The
+fixed-head proof does recurse through the interpretations of both the head
+term and its registered type, but the first paired implementation exposed a
+false interface. `LE_Interp` and its constant payload are propositions, so
+proof irrelevance identifies constructor trees that chose different abstract
+relations. Consequently `recRDeep₂` is sound only for results independent of
+that proof choice; it cannot retain the exact evaluator branch. Focused
+conversion and application probes also showed that no ordering of two
+homogeneous proof trees supplies both an arbitrary converted type and the
+term/type role swap needed by application.
+
+`LE_Interp.Witness` is now the proof-relevant mirror at this internal
+boundary. Every public interpretation noncomputably chooses one consistent
+witness; `Witness.toInterp`, `witness_toInterp`, `Witness.mono`,
+`Witness.recR`/`recRIndex`, and `Lower.realizeWitness` preserve the exact
+constant relation and recursive callback while public conclusions remain
+proof-independent. The layer builds and audits at
+`[propext, Classical.choice, Quot.sound]`. `recRDeep₂` remains available for
+proof-independent consumers, but is no longer the planned evaluator
+recursor. The live adequacy constant case now destructs `hM.witness`, so its
+`R` callback returns exact witnesses rather than reconstructed propositions.
+`Witness.recDeep` now supplies exact ordinary and registered children for the
+inner stratified induction, and proof-relevant `recDeep₂` supports term/type
+role swaps without erasing either callback tree. `RHS.fixedWitness`/`fixedLowerWitness`,
+`Witness.mono_l`/`closed`, and
+`IotaRHSDefEq.of_nonbotWitness` carry that callback through the reached fixed
+RHS head and expose it to the generated-chain consumer. The retained-tree
+finite merge is complete too: `RDeepChildren.JoinLaws` states the four exact
+closure laws, and proof-relevant `compat_join` constructs one synchronized
+joined witness/tree through applications, binders, and constant evaluators.
+`RDeepChildren.Laws`, `TypedRDeep.lam`, and `TypedRDeep.forallE` now close the
+same retained package under weakening and both binders.  The conversion probe
+then fixed the recursion order: `recNatRDeep`/`recNatRDeep₂` make stratified
+depth the primary decrease, so a smaller conversion premise can restart on
+an arbitrary exact target witness without assuming its retained tree.
+`FitsRDeep`, `SoundRDeepAt`, `soundRDeepRestart`, and
+`recNatRDeepSound` kernel-check the complete syntax-directed induction,
+including application, lambda, Pi, and conversion.  All audit at the same
+clean baseline. The remaining work is now the consumer-specific `buildP`
+algebra. Its dependent-application core is isolated in the clean
+`LR.adequateApp` lemma: three lower callbacks (function, argument, and
+instantiated result) discharge the complete application shape join at the
+standard axiom baseline. The retained self-typing probe instantiates that
+interface directly. What remains is the conversion/type-relation handoff
+and constant case, then consuming the rectangle along the generated
+`ShapeSpine` and folding the sole adequacy leaf.
+
+Exit measurement: `sort_invS` reaches
+`[propext, Classical.choice, Quot.sound]`. Record that
+`SExpr.forallE_inv` and `SExpr.sort_forallE_inv` went clean at the same
+moment; their VExpr reflection is a joint L4L-16 co-deliverable at 16E.
+
+### L4L-16D — live-environment instance, staged (the real risk)
+
+The only segment never executed end-to-end. De-risk with a thin vertical
+slice before full coverage:
+
+- **D0 (slice) — complete 2026-08-14 in the active working tree:** the
+  generated Nat block's zero/successor iota rules plus the checked
+  `d0def : Nat := Nat.zero` declaration run through complete
+  `Params` + `Params.Semantic` values, with `d0SortInvS` instantiated.
+  `SExprParamsD0.lean` has no local admission, its 122-job Lake target is
+  green, and the exact inherited endpoint closure is pinned in-source.
+- **D1 — delivered 2026-08-15 (working tree), except the quot semantic
+  instance:** `SExprParamsD1.lean` (187 decls, no local admission).
+  Mutual-definitions half complete end to end: first live
+  `VDecl.WF.mutualDef` (genuine forward reference inside the block; a
+  three-layer unfolding chain through `d0def` exercises
+  `IsDefEqStrong.defn` in sequence), D0→D1 transport functor with the
+  previously-vacuous `const`/`defn` cases now live, full
+  `Params.Semantic` with the Nat iota sites replayed against `d1Env`,
+  endpoint `d1SortInvS` pinned (closure = D0's set + named D1-local
+  `native_decide` observations; `sorryAx` inherited from 16C′ only).
+  Quotient half: environment layer delivered and pinned sorryAx-free
+  (`d1qEnv_wf` with a checked `VDecl.WF.quot` step,
+  `d1qEnv_defeq_quot`), plus the kernel-checked forcing lemma
+  `quotPattern_forces_ctor_classification`; the quot
+  `Params`/`Params.Semantic` instance is blocked on a 16C′-owner
+  interface decision (guardrail #3): any WF classifier forces
+  `Quot.mk = .ctor 3`, and `Semantic.ctor`'s unrestricted level
+  quantifier then violates `CtorBundle.hu0` at Prop instantiations —
+  the punit disqualification biting a live constructor. Candidate
+  repairs recorded at `SExprParamsD1.lean:2703–2755`
+  (typing-conditional `hu0`, or well-sorted-instantiation restriction
+  of `Semantic.ctor`); independently the quot site-check needs
+  stuck-`Quot` injectivity (L4L-18A′ strength). Take the interface
+  decision before any further quot attempt.
+- **D2:** ordinary/block inductive rules via `AssembledPat`. **The new
+  mathematics is done (probe-proved 2026-08-15, kernel `decide` only —
+  no `native_decide`):** `plans/probes/probeD2-nonoverlap.lean` proves
+  the four union-level laws in exact `Params`-field shape under a
+  single `ExtSeparation` hypothesis (self/block/uniqueness/pairwise
+  separation — each field a fixture obligation, `decide`-dischargeable
+  for literal-name fixtures), the cross-term engine
+  (`SimplePattern.HeadSep.inter_subpattern_none`), and a falsity
+  witness showing the hypothesis-free `pat_uniq` is unprovable. The
+  real cross-term case is block-rule vs extension-rule; cross-inductive
+  pairs inside one block were already covered by `IotaPat.pat_uniq`.
+  The demo instantiates the whole family on the mutual
+  PatTree/PatForest block + quot extension. **Landed 2026-08-15**:
+  Parts 1–3 in `Theory/Typing/InductivePatternEnv.lean` and the demo
+  in `InductivePatternFixtures.lean`, strictly additive, all
+  `#guard_msgs`-pinned (engine laws at `[propext, Quot.sound]`);
+  `Lean4Lean.Theory` gate green; D0/D1 rebuilt downstream with pins
+  re-verified. **D2 fixture delivered 2026-08-15 through the
+  structural layer:** `SExprParamsD2.lean` (1033 lines, 75 decls, no
+  admission, 9 pins) — `d2Env` extends d1Env with a *checked* mutual
+  block step (`VDecl.WF.inductBlock`), and `d2Params` is the first
+  complete structural `Params` over a live block-inductive
+  environment. It uses the Tree/TreeList block, not PatTree/PatForest,
+  because only `treeGeneration` carries a proved `gen.WF` certificate.
+  All four non-overlap laws discharged through the freshly landed
+  Theory lemmas by kernel `decide` (no `native_decide` anywhere in the
+  pattern layer) — the union machinery worked as designed on first
+  live contact. Remaining D2: `Params.Semantic`'s
+  `iotaSite`/`registered` for the 5 block rules plus `ctor`/`defn` via
+  the D1→D2 transport clone. **CORRECTED 2026-08-15: not pure volume.**
+  Tree's parameter makes each rule's iota `checked` discharge (one
+  `.defeq` of the ctor-side vs rec-side parameter capture per rule) a
+  stuck-inductive-application-injectivity obligation — L4L-18A′
+  strength (probeG `iotaCheck_param`), so D2's semantic layer closes
+  only conditionally on one named per-rule premise. The measured
+  volume figure was also an undercount: ~640 lines was `iotaSite` for
+  TWO rules; a new rule's full cost including the 6-theorem
+  `registered` tower is ~1400–1700 lines (D0's Nat towers measure
+  1166/1433), i.e. ~7000–8500 for five rules by hand — hence the
+  generic replay lemma below is mandatory, not optional. Original
+  record: ~640 lines/rule of evidence-rich replay over an
+  8-argument major at `uvars = 2` (large elimination adds the motive
+  universe; D0/D1 only ever saw `uvars = 1`). Forcing lemmas
+  `d2Pat_block_rule`/`d2Registered_obligation` pin both fields as
+  obliged. **Cost-control decision to take before D3:** the per-rule,
+  per-fixture replay is what makes D2–D4 expensive; a generic replay
+  lemma parameterized over the generation certificate would retire all
+  five at once and pay off again on D3/D4 (the generic-instance design
+  doc reaches the same conclusion from the other side, and warns that
+  iota *check* discharge — one check per parameter and per index —
+  needs stuck inductive-application injectivity, never exercised
+  because Nat has neither parameters nor indices; Tree has a
+  parameter, so this bites exactly at D2's `iotaSite`).
+- **D3:** nested rules as registered equations only (per roadmap).
+- **D4:** registered structure eta from the L4L-15B registry.
+
+Explicitly OUT of L4L-16: constructing Theory's `Params`/
+`Params.Extension.join` live instance (consumed only by
+`IsDefEq.church_rosser`; needs L4L-17-strength inversion fields). It
+moves to L4L-18A′. The roadmap's §2.1 "Not claimed" paragraph should be
+amended accordingly.
+
+### L4L-16E — promotion (recon executed 2026-08-15)
+
+Executable checklist with full citations: `plans/l4l-16e-promotion-map.md`
+(move-map, allowlist edits, gate table with the expected re-pin sets,
+type-checked draft statements in `plans/probes/CoDeliverableDrafts.lean`
+and `plans/probes/SExprCounterpartDrafts.lean`).
+
+Move the consumed modules out of `Experimental/`, close public
+`IsDefEqU.sort_inv` from the instances, shrink the allowlist 22 → 21 at
+the promotion checkpoint (execution step 6; step 7's co-deliverables
+then take it to 17), add the missing `#guard_msgs`/`#print axioms` pins
+for the promoted roots (none exist today because Experimental is
+ungated), and take the digama reconcile-or-defer decision (prepared
+analysis with defer recommendation:
+`plans/l4l-16-boundary-digama-drift.md`). The recon surfaced items the
+plan had not assigned; they are 16E work items now:
+
+- Both co-deliverables already exist as sorried statements in the
+  trusted tree — `IsDefEqU.weakN_iff`
+  (`Theory/Typing/UniqueTyping.lean:171`, backward direction proved,
+  forward/strengthening open) and `WF.registeredStructureHeadInversion`
+  (`Theory/Projection.lean:3518`). Nothing needs drafting; 16E proves
+  them and re-pins the ~10 downstream guards that flip.
+- **`weakN_iff` forward — design pass executed 2026-08-15; verdict:
+  research-grade, not closable inside 16E** (route decision + staged
+  obligations: `plans/l4l-16-weakn-design.md`; W0–W8 type-checked in
+  `plans/probes/probeE-weakn.lean`). Chosen route: SST —
+  de-circularized stratified standardization on the Theory side; the
+  forward direction assembles in ~15 lines from three staged lemmas,
+  but their cores (`NormalEq.weakN_inv` mutual with `trans` on a
+  (depth, meas, derivation) measure; per-depth CR re-founding) are 3–6
+  focused weeks, after the 16C′ endpoints and the 18A `.extra` holes.
+  Rejected routes carry machine-checked obstructions (W0
+  trans-midpoint re-lift gluing witness, proved; semantic descent
+  impossible by relation design — bot shape relates all terms;
+  Theory-CR circular definitionally and at the `Params` oracle
+  fields). Banked now at `[propext, Quot.sound]`: W0 and W1
+  (`strengthen_of_witness`, forward under inhabited insertion).
+  **Ladder attacked the same day — W2 and W3 are PROVED**
+  (`plans/probes/probeE2-weakn-w2w3.lean`, exit 0, no sorries in the
+  probe; closures `[propext, sorryAx, Classical.choice, Quot.sound]`
+  with every `sorryAx` traced to four named upstream stubs). Headline
+  correction: W2/W3 are not "real work" — they are *consumers*, and
+  the design doc's dependency arrow was inverted (W3 uses W2, not the
+  reverse; W2's only non-elementary input is `InferType.exists`, i.e.
+  the W6 CR core). Both statements were *strengthened*: probe E's
+  `hA : IsType` / `hF` hypotheses are redundant — which matters,
+  because the SST assembly's caller does not have base-context typing
+  before strengthening. Blocking delta discovered: the bare-`VEnv.WF`
+  forms are not provable today — the engine is `[Params]`-generic and
+  needs `[Params.Extension]`, so W2/W3 ride on the same
+  generic-instance debt as W8 and `sort_inv` (see below). Bonus
+  de-circularization: `OnCtx.weakN_inv` (UniqueTyping.lean:198), a
+  direct consumer of the target sorry, is re-proved from
+  `IsType.weakN_inv_ex` alone. Revised remainder: 2.5–5 weeks serial,
+  or **8–11 staged agent sessions**, with W5+W6 (the coupled
+  `NormalEq`/CR cores) carrying essentially all residual risk. W4's
+  route is settled as option (a) `Pattern.Action` packaging (`meas` is
+  lift-invariant and a rule RHS may exceed the redex, so neither
+  `meas` nor size bounds the payloads). One newly-scoped ~1-session
+  piece de-circularizes W2 alone: re-prove `InferType.weakU_inv` by
+  size induction with a type-level strengthening premise.
+  **DECISION REQUIRED:** re-scope `weakN_iff` (and the dependent
+  `registeredStructureHeadInversion` fields that consume it) off the
+  16E gate into an L4L-18A′-coupled slice — both design passes
+  recommend yes; 16E's allowlist exit count then lands at 19, not 17.
+- **`registeredStructureHeadInversion.constructor_name_inv` /
+  `constructor_inv` are false as stated** (axiom-headed major and
+  defn-alias counterexamples; `TrProj` constrains only the major's
+  type, and the safe Verify consumer's `whnf`+`ctorInfo` facts never
+  reach the Theory statement). Repair with a head-classification
+  premise before proof work; budget the consumer-side change.
+- **Pre-promotion sorry closure step (new):** the four off-path
+  `SExpr.lean` sorries (:3810 `WHRed.weakU_inv` `.extra`; :4033
+  `WHRedS.defeq` — superseded by `defeq_of_stratified_inversion`,
+  delete/restate and migrate its two consumers; :4136/:4202
+  `InferType(S).hasType`) do NOT close with the leaf and block the
+  module move; they get their own step before promotion.
+- **Instance generalization — design pass executed 2026-08-15;
+  recommendation: neither D4's endpoint nor a 16E step, but a named
+  successor milestone (L4L-16F)** (`plans/l4l-16-generic-instance-design.md`,
+  staged obligations R0–R9 type-checked in
+  `plans/probes/probeG-generic-instance.lean`). `sort_invS` holds at
+  `[Params.Semantic]`; public `sort_inv` quantifies over arbitrary
+  `VEnv.WF env`. A *conditional* instance was checked and refuted as a
+  route: `adequacyAt` quantifies over all derivations and `mkS`
+  demands `Semantic.ctor` at every `constDF` node of the arbitrary
+  input derivation, so the restriction cannot be moved onto the goal —
+  a conditional instance just restates the fixture ladder. Banked
+  results: promotion is one instance wide (R0); the syntax transport
+  functor is generic in `univs`-equality (R1 — deletes ~1200 lines of
+  D0/D1 boilerplate and pays off again on D2–D4, so land it BEFORE
+  more fixture work). Attackable now without any interface decision:
+  R2 (per-step extension theorem — the D-ladder's transport pattern
+  literally IS the induction step, with only five new-content fields
+  varying per rung), R3 (classify/`pat_wf` packaging), R4
+  (`ExtSeparation` from history freshness — 6 new lemmas; provably not
+  droppable per `separation_is_necessary`), R5 (`defn` at `uvars > 0`).
+  Note `structureEta` is vacuous in all three existing instances —
+  never once exercised. **Circularity trap recorded:** the generic
+  construction must NOT consume Theory's `BlockGenerationChecked.pat_wf`
+  — it carries `sorryAx` through `IsDefEqU.trans` → `uniq` → the
+  sorried `sort_inv`.
+  **New hard constraint on the entry point (proved 2026-08-15,
+  `plans/probes/probeK-deltarank.lean`): `VEnv.WF` admits δ-cycles.**
+  `VDecl.WF.mutualDef` (`Theory/Typing/Env.lean:28-32`) adds every block
+  constant BEFORE checking any block value, so
+  `mutual def a : Prop := b; def b : Prop := a end` is a well-formed
+  history — the probe constructs it, proves both `VEnv.Ordered` and
+  `VEnv.WF` for it, then proves no δ-rank function can exist for it.
+  Consequences: (i) the δ-rank the 16C′ leaf needs cannot be derived
+  from `Params.henv` and must be `Params` fields; (ii) a generic
+  `VEnv.WF → Params` construction therefore CANNOT discharge those
+  fields in general — 16F must either exclude cyclic definitions from
+  `Pat` (handling them through `Semantic.registered` as opaque
+  constants) or carry δ-acyclicity as an explicit environment
+  hypothesis. Decide that at 16F's design, not at implementation.
+  Independently worth noting: a δ-cyclic definition makes δ-reduction
+  non-terminating, so this is a point where the VEnv model is more
+  permissive than the kernel it models.
+- **`CtorBundle.hu0` — recommendation: delete the field outright**
+  (supersedes both candidate repairs recorded in the D1 quot record).
+  Banked evidence: `hu0_impossible_at_prop` (under type uniqueness no
+  `CtorBundle` can satisfy it for a Prop-typed constructor — the wall
+  is intrinsic, not a fixture artifact) and `propWitness_of_ctor_zero`
+  (the Prop typing is free from the bundle's own equality, so no
+  replacement field or premise is needed). The wall is far wider than
+  D1 recorded: not just `Quot.mk` at `[.zero]` but every constructor
+  of a Prop-sorted inductive (`Eq.refl`, `And.intro`, `Acc.intro`) at
+  *every* instantiation, since a constructor's type ends in its
+  inductive type and `imax _ 0 = 0`. **SUPERSEDED 2026-08-15: the
+  deletion is REFUTED by the executed discriminating experiment**
+  (`plans/probes/probeA1-hu0.lean`, run at both consumption sites).
+  The ADQ site is free (`u ≠ .zero` is derivable there from the
+  ambient `.indTy`-shaped interpretation — probe P4), but
+  `build_spine`'s post-deletion statement is FALSE for Prop-sorted
+  ctor-classified pattern-argument heads: `Matches.app` hard-codes the
+  `.ctor'` spine entry, whose realization forces
+  `.indTy.HasType .type`, provably impossible at Prop (probe P2). Root
+  cause: the shape algebra's proof-irrelevance law
+  (`WShape.HasType.proofIrrel`) requires `.indTy` non-Prop-sortedness,
+  and `hu0` is that law's syntactic mirror — relaxing the `hasType`
+  indTy row makes `proofIrrel` false. Landing any resolution therefore
+  needs a DESIGN, not a deletion: either a Prop-branch at the
+  Matches/classification level (not expressible in `Pattern.WF`'s
+  classify-only signature) or exclusion of Prop-recursor iota patterns
+  from `Pat` with a matching nonzero-sort law. Consequently D1's
+  quotient half remains blocked on that design (obstruction 1 stands),
+  in addition to obstruction 3's stuck-`Quot` injectivity (L4L-18A′);
+  only obstruction 2 would dissolve under any resolution that keeps
+  the pattern in `Pat`. The dead `Params.ctor_ty` re-export was
+  deleted independently (zero consumers).
+- Mechanical but previously unlisted: regenerate
+  `Audit/SorryFrontier.lean`'s import block at promotion (else the
+  moved modules silently leave the audited surface); resolve the
+  `Experimental/UniqueTyping.lean` filename collision (fold into the
+  adequacy module or rename); consider the `SExpr.Params` rename for
+  the `Lean4Lean.Params` vs `VEnv.Params` near-collision during API
+  stabilization.
+
+### L4L-17′ — re-scoped
+
+1. **Reflection first** (already the roadmap's position, now sharper):
+   decide conservativity-lemma vs adequacy-restated-on-VEnv. Note `mk`
+   is a proved retraction (surjective), so naive injectivity is
+   unavailable; any faithfulness statement is modulo `≈`.
+2. Reflect `forallE_inv_stratified` and `sort_forallE_inv` (SExpr halves
+   already delivered by 16C′).
+3. `weakN_iff` (forward direction) and
+   `registeredStructureHeadInversion` — no SExpr counterparts yet; and
+   whatever Option B promoted, generalize here.
+4. Re-run `uniq`/`uniqU` and downstream guards (unlocks the transitional
+   closure: `pat_wf`, projection consumers).
+
+### L4L-18A′ — grows, honestly
+
+Theory `NormalEq.parRed` holes (as before) **plus** the work moved here:
+Theory-side live `Params`/`Params.Extension.join` instance (its four
+structEta/forallE fields now supplied by L4L-17 outputs), and only then —
+if any promoted statement still needs it — the SExpr Church–Rosser mirror
+(S6). Expected outcome: S6 is simply deleted along with `CRDefEq` if no
+promoted API consumes it.
+
+## 4. Execution order and checkpoints
+
+Each numbered item is one committed checkpoint (jj makes this cheap);
+Experimental stays buildable at every pause point.
+
+1. **Stabilize & checkpoint L4L-16A(+)**: single writer designated
+   (§5.1); commit the current working copy as the L4L-16A checkpoint with
+   the roadmap corrections from §1.2 (plift, six fields, S1/S7–9
+   verdicts, S6 move). Gated surface is untouched by the diff, so §6
+   gates pass as-is; run them anyway.
+2. **16B′ cleanup** (delete/restate items — small, mechanical).
+3. **16C′ joint interface + O1 normalization** (**kernel-checked in
+   the current working tree**: limited uniqueness contract,
+   level-indexed adequacy/inversions, `mk` reflection boundary, and
+   `CtorLink`/`CtorChain`/`toChain`).
+4. **16C′ O3 + O2 leaf closure.** The path/direct stratified inversion
+   bootstrap, generic uniqueness theorem, chain consumer, and root subject
+   reduction are kernel-checked; the exact successor lambda-retyping and
+   synchronized endpoint rectangle are implemented. Complete the canonical
+   deep-`R` fixed-head application chain and fold the leaf → measured clean
+   `sort_invS`; SExpr `forallE_inv`/`sort_forallE_inv` recorded clean.
+5. **16D0 slice**, then **16D1–D4** as separate checkpoints.
+6. **16E promotion** + allowlist 21 + digama decision.
+7. Land the former L4L-17 statements as the joint 16E co-deliverables.
+
+Rough effort guess (calibrate against how fast 16A went): 1–2 days for
+1–2; the 16C′ spike+closure is the genuine unknown — timebox the spike,
+expect days not hours for closure; 16D is 1–2 weeks of mostly
+certificate plumbing; 16E days.
+
+## 5. Anti-spin guardrails (process)
+
+1. **One writer.** Exactly one session edits `Experimental/` at a time.
+   Right now at least two AI sessions plus an auditor share this working
+   copy; pick one (the pts/3 codex session and pts/11 Claude session
+   cannot both continue).
+2. **Checkpoint every kernel-checked sub-result.** No more 18-hour
+   uncommitted mega-changes; the ladder's one-claim-per-checkpoint rule
+   applies to Experimental work too.
+3. **Two-strikes rule.** Two failed repair attempts on the same
+   obligation → stop, write the obligation as a Lean statement in the
+   plan file, and make an interface decision before more proof text.
+4. **Roadmap is status, not lab notebook.** Move the L4L-16C attempt
+   narrative (~100 lines) into `plans/l4l-16c-adequacy-log.md`; the
+   roadmap keeps a 5-line status per slice. (The narrative was valuable —
+   it is how this audit found the root cause — it just belongs in a log.)
+5. **Measure, don't assert, closures.** The roadmap carried three stale
+   claims about this work (plift `stop`, five fields, `WHRed.subst`
+   `.extra` open). Add a tiny uncommitted probe file with
+   `#print axioms` for the route waypoints and re-run it at every
+   checkpoint until 16E's real guards exist.
diff --git a/plans/l4l-16-generic-instance-design.md b/plans/l4l-16-generic-instance-design.md
new file mode 100644
index 00000000..43646d56
--- /dev/null
+++ b/plans/l4l-16-generic-instance-design.md
@@ -0,0 +1,613 @@
+# L4L-16 generic `Params`/`Params.Semantic` instance — design pass
+
+Date: 2026-08-15
+Author: design-pass session (agent G), commissioned by the L4L-16E
+"DECISION REQUIRED" line in `plans/l4l-16-completion-plan.md:781-785`:
+
+> **Instance generalization is implicit and unstaged:** `sort_invS` holds at
+> `[Params.Semantic]`; public `sort_inv` quantifies over arbitrary
+> `VEnv.WF env`. "Closes from the instances" needs the generic
+> `Params`/`Params.Semantic` construction from any WF history — decide at D4
+> exit whether that is D4's endpoint or a named 16E step.
+
+Status: analysis complete; recommendation below. Companion probe:
+`plans/probes/probeG-generic-instance.lean` (green, six banked results at
+`[propext, Quot.sound]`). No `Experimental/` or `Theory/` file was edited.
+
+---
+
+## 0. TL;DR
+
+**The pending decision is posed on a false trichotomy.** The generic
+construction is neither D4's endpoint nor a 16E step nor usefully
+conditional. It is a milestone-sized development containing **three
+independent walls**, two of which are owned by other milestones:
+
+1. **`CtorBundle.hu0` vs. Prop-typed constructors** — strictly worse than the
+   D1 record says. D1 found it for `Quot.mk` at `ls = [.zero]`; in fact
+   *every* constructor of a `Prop`-sorted inductive (`Eq.refl`, `And.intro`,
+   `Exists.intro`, `Acc.intro`, …) violates `hu0` at *every* instantiation,
+   because a constructor's type ends in its inductive type and `imax _ 0 = 0`.
+   No environment containing `Eq` can carry the instance. **Banked**
+   (`hu0_impossible_at_prop`): under type uniqueness, *no* choice of
+   `CtorBundle` can repair this — the failure is intrinsic, not a bad-bundle
+   artifact.
+2. **Iota check discharge for parameters/indices** — `Semantic.iotaSite` must
+   supply `IotaReductionSite.checked`; `gen.ruleCheck` emits one check per
+   parameter and per result index; discharging them at a matched redex needs
+   injectivity of a stuck inductive-type application, which is L4L-18A′
+   strength. **This wall is recorded nowhere in the plan and bites D2 before
+   it bites the generic construction** — D0/D1 pass only because Nat has no
+   parameters and no indices (`dfs := []; checked := by simp`).
+3. **`Semantic.structureEta` for a nonempty eta registry** — Theory takes
+   `IsDefEqStrong.structEta` as a *primitive rule*; SExpr's judgment has no
+   such constructor, so the field asks the SExpr layer to *prove* what Theory
+   *assumes*. Structure eta does not follow from iota at a stuck major. All
+   three existing instances discharge this field vacuously. `VEnv.WF'`
+   admits eta rules, so an arbitrary WF environment can have them.
+
+**Conditional instances do not rescue the target.** The restriction cannot be
+pushed onto the goal: `sort_invS` consumes `LR.adequacyAt`, a theorem about
+*all* derivations, and `IsDefEqStrong.mkS` demands `Semantic.ctor` at *every*
+`constDF` node of the *input* derivation. A "non-Prop fragment" instance
+therefore yields `sort_inv` only for environments with no Prop-sorted
+inductive, no parameterised inductive, and no eta registry — i.e. the D0–D2
+fixture ladder, not a public theorem.
+
+**Recommendation:** re-scope the public `IsDefEqU.sort_inv` promotion **off
+the 16E gate** into a named successor milestone (§8), exactly as
+`plans/l4l-16-weakn-design.md` recommends for `weakN_iff`. 16E then exits on
+the SExpr-side statements plus fixture-instantiated endpoints. Four of the
+seven staged rungs (§7) are attackable *today* with no interface decision,
+and one of them — the generic syntax transport — is already banked in the
+probe and deletes ~1200 lines of D-ladder boilerplate.
+
+**One trap worth naming up front:** the generic construction must **not**
+consume Theory's `VInductDecl.BlockGenerationChecked.pat_wf`
+(`Theory/Typing/InductivePatternWF.lean:543`). It measures at
+`[propext, sorryAx, Classical.choice, Quot.sound]` (`:942-949`) because it
+composes typed defeqs through `IsDefEqU.trans`
+(`Theory/Typing/UniqueTyping.lean:167`) → `uniq` → the sorried `sort_inv`.
+It is the natural-looking source for "the rule fires soundly", and using it
+would make the promoted theorem circular.
+
+---
+
+## 1. What exactly is missing (and what is not)
+
+`VEnv.IsDefEqU.sort_invS` (`Experimental/ShapeLogRelAdequacy.lean:7064`):
+
+```lean
+theorem _root_.Lean4Lean.VEnv.IsDefEqU.sort_invS [Params.Semantic]
+    (hΓ : OnCtx Γ (Params.env.IsType Params.univs))
+    (h : Params.env.IsDefEqU Params.univs Γ (.sort u) (.sort v)) : u ≈ v
+```
+
+Public target (`Theory/Typing/Injectivity.lean:11`):
+
+```lean
+theorem IsDefEqU.sort_inv (henv : VEnv.WF env) (hΓ : OnCtx Γ (env.IsType U))
+    (h1 : env.IsDefEqU U Γ (.sort u) (.sort v)) : u ≈ v := sorry
+```
+
+`Params` is a *class whose `env` and `univs` are fields*, so "an instance for
+`env` at `U`" is a Σ-type, not a typeclass search. Probe §G0 pins that the
+whole remaining gap is that Σ-type:
+
+```lean
+structure GenericInstance (env : VEnv) (U : Nat) where
+  params : Params
+  env_eq : @Params.env params = env
+  univs_eq : @Params.univs params = U
+  semantic : @Params.Semantic params
+```
+
+**Banked** (`sort_inv_of_generic`, probe): given the bundle, the public
+statement follows in five lines with no further semantic work — the promotion
+step really is exactly one instance wide. Its measured closure is
+`[propext, sorryAx, Classical.choice, Quot.sound]`, the `sorryAx` inherited
+from `sort_invS`'s 16C′ leaf, not from the probe.
+
+So the gap is exactly:
+
+```lean
+noncomputable def genericInstance (env : VEnv) (hwf : env.WF) (U : Nat) :
+    GenericInstance env U
+```
+
+---
+
+## 2. Field-by-field generalization table
+
+Discharge classes, per the commission's taxonomy:
+**(a)** literal-name computation (`decide`/`native_decide` freshness,
+classify tables, rule inventories); **(b)** structural transport (the
+d(n)→d(n+1) functor); **(c)** genuinely semantic content (iota-site replay,
+`IsDefEqStrong` chains, eta registry).
+
+### 2.1 `Params` (11 fields, `Experimental/SExpr.lean:24-45`)
+
+| Field | Fixture discharge | Class | Generic source | Verdict |
+|---|---|---|---|---|
+| `env` | literal `d0Env`/`d1Env` | — | the given `env` | trivial |
+| `henv : env.Ordered` | `d0Env_wf.ordered` (D0:87) | (b) | `VEnv.WF.ordered`, `Theory/Typing/EnvLemmas.lean:88` | **exists** |
+| `univs` | parameter | — | the given `U` | trivial |
+| `classify` | literal `match` tables: `natClassify` D0:114, `d0Classify` D0:122, `d1Classify` D1:248; freshness by `native_decide` (D0:57-63, D1:68-92) | (a) | per-rung `blockClassify` from the certificate inventory (`gen.families`, `gen.flatCtors`, `gen.recursors`), `.symb 0` per def rung, unioned along the history | **needs new lemma** (G4a): inventory exists, packaging as `Name → Option Classification` does not |
+| `Pat` | inductive, one constructor per rule: `D1Pat` = `old`/`defnA`/`defnB` (D1:245-270) | (a)+(b) | `AssembledPat`-shaped union: `gen.IotaPat` per block rung, `.const c` per def rung | mechanical induction |
+| `pat_simple` | case split → `IotaPat.pat_simple` / `⟨.defn c, rfl⟩` (D0:272) | (b) | `AssembledPat.pat_simple`, `InductivePatternEnv.lean:529` | **exists** |
+| `pat_wf` | `natPat_wf` D0:256 by `decide` on the literal table; D1 lifts via `d0Classify_agrees` D1:279 | (a) | pattern heads are `gen.ruleRecName c` / `c.ctor.raw.name` **by construction** | **needs new lemma** (G4b): true by definition; *no lemma states it* |
+| `pat_uniq` | `d0Pat_uniq` D0:313 / `d1Pat_uniq` D1:374, via literal-name `*_inter_*_none` lemmas | (a) | `AssembledPat.pat_uniq` under `ExtSeparation`, `InductivePatternEnv.lean:570` | **needs new lemma** (G5): union law exists (landed today); `ExtSeparation`-from-history does not |
+| `pat_app_l` | `d0Pat_app_l` D0:340 → `toPattern_app_l` | (b) | `AssembledPat.pat_app_l` (side-condition free) | **exists** |
+| `pat_app_l_uniq` | as `pat_uniq` | (a) | `AssembledPat.pat_app_l_uniq` under `ExtSeparation` | **needs G5** |
+| `pat_app_uniq` | as `pat_uniq` | (a) | `AssembledPat.pat_app_uniq` under `ExtSeparation` | **needs G5** |
+
+Note the generality limit of today's engine: `AssembledPat` is parameterized
+by **one** `gen : source.BlockGenerationChecked` plus a list of
+`CertifiedExtension`s (`InductivePatternEnv.lean:520-526`). An arbitrary
+history has many blocks. Two routes: (i) encode every non-distinguished block
+as `CertifiedExtension`s via `gen.iotaExtension` (`:347`) — available, but
+then those rungs lose the `IotaPat` payload structure the `Semantic` fields
+want; (ii) generalize `AssembledPat` to a list of blocks. (ii) is cleaner and
+is the same proof: the cross-term engine
+`HeadSep.inter_subpattern_none` (`:160`) is already fully generic in both
+patterns.
+
+### 2.2 `Params.Semantic` (6 fields, `Experimental/SExpr.lean:1964-2050`)
+
+| Field | Fixture discharge | Class | Generic source | Verdict |
+|---|---|---|---|---|
+| `structureEta` | **VACUOUS in all three instances** — `natSemantic` D0:5570, `d0Semantic` D0:6880, `d1Semantic` D1:2621, each `(*_no_structEta rule hreg).elim` | never exercised | Theory's primitive `IsDefEqStrong.structEta` (`Theory/Typing/Strong.lean:74-87`) has **no SExpr counterpart** | **BLOCKED on interface repair** (§5.3, G8) |
+| `ctor` | `natCtor` D0:1597 (hand-built bundle + strong Pi-tower typing for `Nat.zero`/`Nat.succ`, ~110 lines of support at D0:1485-1605); `d0Ctor` D0:6033 and `d1Ctor` D1:1885 are pure transports | (c) then (b) | per-block: the constructor's type IS a Pi telescope ending in `I args`, pinned by the generation certificate | mechanical-ish, **but `hu0` is BLOCKED** (§5.1, G6) |
+| `defn` | `d0Defn` D0:6116, `d1Defn` D1:1758 — case split on the registry, each case a hand-built `IsDefEqStrong.defn` (`d1MutADefStrong` D1:1709, `d1MutBDefStrong` :1651) | (b)+(c), fully templated | per-def rung: `.const c` pattern → `IsDefEqStrong.defn` with `action` from `IsDefEq.extra` at the closed constant | **mechanical induction**; one genuinely new sub-case: `uvars > 0` (every fixture ran `uvars = 0`, cf. `List.length_eq_zero_iff.mp hlen` at D1:1785) |
+| `iotaRule` | `natIotaRule` D0:1943 / `d1IotaRule` D1:1466 — `Classical.choice` of a nonemptiness proof recovering the descriptor from the pattern | (a)+(b) | `IotaPat.recover` (`InductivePattern.lean:624`) + `gen.rule` / `gen.rule_uvars` | **mechanical** |
+| `iotaSite` | `natIotaSite_nonempty` D0:1954-2578 (624 lines), `d0IotaSite_nonempty` D0:6199-6829 (630), `d1IotaSite_nonempty` D1:1930-2569 (639) — hand-built typed telescopes; **all three end `dfs := []; checked := by simp`** (D0:2569-2572, D0:6825-6828) | (c) | per-block site construction from `gen`'s rule shape | **partially BLOCKED**: `captureSpine` needs a new generic telescope lemma (hard but plausible); `checked` is BLOCKED for parameters/indices (§5.2, G7) |
+| `registered` | `natRegistered` D0:5497 → `natZeroRuleRegistered` D0:3930 / `natSuccRuleRegistered` D0:5325, each on top of ~700 lines of `*RuleBodyStrong` / `*RuleAppliedStrong` / `*RuleActionSound` / `*RuleLocalStrong` / `*RulePrefixesStrong` (D0:2898-5497). `d1Registered` D1:1821 transports old rules and hand-builds the two new ones | (c) | per-rung: def/mutualDef rungs reduce to `defn`; block rungs need a generic `lamN`-tower descent + `IotaReductionSite.action` | **needs new lemma** (substantial); inherits G7 |
+
+**Reading of the table.** Only two `Semantic` fields (`iotaRule`, `defn`) are
+mechanical. `ctor` and `registered` are per-block semantic content with a
+uniform shape that a generation-certificate-parameterized lemma can capture.
+`iotaSite` and `structureEta` are the walls. The ~2000 fixture lines behind
+`registered` are *not* irreducible: they are the concrete instance of a
+uniform recipe — descend the registered rule's `lamN` binder tower with
+`lamDF`, expose the redex, build the local `Pattern.Action` by applying the
+closed registered equation to the binder spine and beta-collapsing. The
+generic engine for the last step already exists and is kernel-checked:
+`Pattern.IotaReductionSite.action` (`Experimental/SExpr.lean:2056-2086`).
+
+**Why `registered` cannot be shortcut.** The tempting route — get the
+equality from Theory by `.extra` + `IsDefEq.strong` + `mkS` — is circular:
+`IsDefEqStrong.mkS`'s `extra` case *is* `Params.Semantic.registered`
+(`Experimental/SExpr.lean:2188-2194`). Likewise its `constDF` case *is*
+`Semantic.ctor` (`:2117-2125`) and its constant-unfolding case *is*
+`Semantic.defn` (`:2132`). The `Semantic` class is precisely the set of
+Theory rules the SExpr judgment has no constructor for.
+
+---
+
+## 3. Construction shape
+
+### 3.1 The induction
+
+`VEnv.WF env := ∃ ds, VEnv.WF' ds env` (`Theory/Typing/Env.lean:67`), and
+`VEnv.WF'` (`:57-65`) is an inductive with three constructors: `empty`,
+`decl` (one `VDecl.WF env d env'` step), `structEta` (an eta-registry
+insertion, *not* a `VDecl`). So the construction is an induction on `WF'`,
+producing a `GenericInstance` at each prefix.
+
+Caveat measured during this pass: **the only consumer of `VEnv.WF'` in the
+entire tree is `VEnv.WF.ordered`** (`EnvLemmas.lean:88`). There is no
+inversion lemma, no `VDecl.names` function, and no "the history's declared
+names are pairwise distinct". Every history-level fact this construction
+wants is new (§6).
+
+### 3.2 The per-step extension theorem — the D-ladder transport, abstracted
+
+**The D-ladder's transport pattern literally is the induction step.** The
+correspondence, checked against `SExprParamsD1.lean`:
+
+| D1 artifact | Abstracted role |
+|---|---|
+| `d0ToD1Level` (D1:484) / `d0ToD1Expr` (D1:514) | the syntax functor — `Step.univs_eq` + `transportExpr` |
+| `d0Env_le_d1Env` (D1:134) | `Step.le` |
+| `D1Pat.old` (D1:245ff) | `Step.pat_mono` |
+| `d1Pat_at_old_const` (D1:988) | `Step.pat_old` — a *new* rule never fires at an *old* constant |
+| `d0StrongToD1` (D1:1004-1107) | `Step.strong` — the judgment transport, one case per `IsDefEqStrong` constructor |
+| `d1Ctor` / `d1Defn` / `d1Registered` old cases | the transport half of each `Semantic` field |
+| `d1MutADefStrong` / `d1MutBDefStrong` / `d1IotaSite_nonempty` | the **new** half — this is what varies per rung |
+
+Probe §G2 types this as `Step P₀ P₁` + `StepObligations P₀ P₁ st` +
+`Semantic.step`.
+
+**What varies, precisely:** only `StepObligations` — the five new-content
+fields (`newCtor`, `newDefn`, `newRegistered`, `newIota`, `newStructEta`).
+Everything else in a rung is boilerplate that is currently rewritten by hand.
+
+### 3.3 Two structural findings that shrink the work
+
+**(i) The syntax functor is generic and is now banked.** `SExpr` is
+`[Params]`-indexed (`Experimental/SExpr.lean:217`), so a history induction
+cannot keep one syntax type across rungs — hence the four hand-rolled
+functors in D0/D1 (`natToD0Expr`/`d0ToNatExpr` D0:583/596,
+`d0ToD1Expr`/`d1ToD0Expr` D1:514/527) plus their roundtrip and commutation
+lemmas: D0:547-1140 and D1:475-1120, ≈1200 lines total. All of it depends
+only on `univs` agreeing. The probe defines `transportLevel` /
+`transportExpr` / `transportLevel_transportLevel` generically, all at
+`[propext, Quot.sound]`. **This is a strict, immediate win for D2/D3/D4
+regardless of the milestone decision.**
+
+**(ii) The pattern registry needs no transport at all.** `Pattern.RHS` and
+`Pattern.Check` (`Theory/Typing/Pattern.lean:96,101`) are `Params`-*independent*
+— `.fixed` carries a `VExpr`, not an `SExpr`. So `Step.pat_mono` keeps `r`
+fixed. (Checked while elaborating the probe; the first draft wrongly assumed
+a `transportRHS` was needed.)
+
+### 3.4 Per-declaration-kind content
+
+| `VDecl` kind | New content | Difficulty |
+|---|---|---|
+| `.axiom`, `.opaque` | none: adds a constant, no defeq, no pattern; `classify` extends by `none`, so `CtorBundle.IsCtor` stays uninhabited and `Semantic.ctor` is vacuous at it | trivial (G3-axiom) |
+| `.example` | environment unchanged | trivial |
+| `.def` | one `.const c` pattern (`classify c = some (.symb 0)`, so **not** a ctor and no `hu0` exposure), one defeq; `defn` + `registered` both from `IsDefEqStrong.defn` | mechanical; new sub-case `uvars > 0` (G3-def) |
+| `.mutualDef` | as `.def`, per block element, with the forward references D1 already exercised | mechanical (D1 is the template) |
+| `.quot` | four constants + `quotDefEq` | **BLOCKED** ×2: `hu0` (§5.1) and stuck-`Quot` injectivity for `quotCheck` (§5.2) |
+| `.induct` (3 variants) | block inventory into `classify`; `gen.IotaPat` into `Pat`; `Semantic.ctor` for the new constructors; `iotaRule`/`iotaSite`/`registered` for the new rules | the substantial rung; **BLOCKED** by §5.1 (Prop-sorted blocks) and §5.2 (parameterised/indexed blocks) |
+| `WF'.structEta` | `Semantic.structureEta` becomes non-vacuous | **BLOCKED** (§5.3) |
+
+---
+
+## 4. Freshness and decidability
+
+The fixtures discharge every name obligation by computation on literal names:
+`native_decide` freshness (D0:57-63, D1:68-92, D1:2767-2812), `decide`
+classify-table lookups (D0:256-290), literal rule inventories
+(`natRulePattern_inventory` D0:167). An arbitrary history has no literals, so
+each of these must come from a WF invariant instead.
+
+**What exists.**
+
+* Freshness is a *consequence of a successful step*: `VEnv.addConst`
+  (`Theory/VEnv.lean:184-187`) returns `none` when the name is taken, and
+  `VEnv.addConst_fresh` (`Theory/Typing/Lemmas.lean:197`) extracts it.
+* Transaction traces carry the block form:
+  `ctorFold_spec` (`Theory/Typing/InductiveLemmas.lean:13828`) gives
+  `env₀ ≤ env₁ ∧ (∀ c ∈ cs, env₁.constants c.name = some _) ∧
+  (∀ c ∈ cs, env₀.constants c.name = none)`;
+  `AddInductBlockGenerationTrace.{family,ctor,rec}_fresh` (`:14091, 14123,
+  14153`) and their `_lookup` siblings (`:14103, 14137, 14167`).
+* Backward monotonicity: `VEnv.LE.constants_none` (`Lemmas.lean:220`).
+* Intra-block distinctness: `blockGeneratedNames_nodup`
+  (`Theory/Typing/InductivePattern.lean:222`), `recName_ne_ctorName` (`:478`),
+  `flatCtors_name_inj` (`:456`), `families_name_inj` (`:443`),
+  `ruleRecName_inj` (`:502`), `rulePattern_inj` (`:519`).
+
+**What does not exist** (each is a named obligation in §7):
+
+1. Any inversion of `VEnv.WF'` / `VDecl.WF`; no `VDecl.names`; no "the
+   history's declared names are pairwise distinct".
+2. `addConsts_fresh` / `addConsts_nodup` — freshness extracted from a
+   *successful* `addConsts` (only the converse `exists_addConsts`,
+   `EnvLemmas.lean:27`, exists).
+3. `addQuot_fresh`.
+4. **"A rule pattern's head names are names this block introduces."** True by
+   construction (`rulePattern` = `.iota (gen.ruleRecName c) _ c.ctor.raw.name _`,
+   `InductivePattern.lean:287`) but stated nowhere. This is the bridge from
+   transaction freshness to `ExtSeparation`.
+5. `nodup_parts` (`InductivePattern.lean:430`) is `private`, so the three
+   component distinctness facts are unavailable outside that file.
+6. `(gen.recursors).map (·.name) ⊆ blockGeneratedNames`.
+
+**And the hypothesis genuinely is necessary.** `separation_is_necessary`
+(`InductivePatternEnv.lean:760`) proves the certificate-free union law false
+— a `defn` extension named after a rule's recursor breaks `pat_uniq`. So
+`ExtSeparation` must be *derived* from freshness, not dropped. The only
+discharge in the tree today is `decide`-based on a literal fixture
+inventory (`patTree_quot_separation`, `InductivePatternFixtures.lean:216`).
+
+**Verdict:** the freshness half is *mechanical but not small* — six new
+lemmas plus one visibility change, all pure bookkeeping over existing
+traces, no semantics. It is attackable today.
+
+---
+
+## 5. The three walls
+
+### 5.1 `hu0` and Prop-typed constructors — the interface repair (recommended)
+
+**What `hu0` does.** `CtorBundle.hu0 : u ≠ .zero`
+(`Experimental/SExpr.lean:1897`) has exactly two consumption sites:
+
+* `LE_Interp.build_spine`, constructor case (`ShapeLogRel.lean:9208-9251`).
+  `hu0` is threaded down the constructor's Pi telescope (`:9230-9242`) so
+  that the inductive-type-headed result can be realized at a **non-bot**
+  sort shape (`:9246`, `.sort (decide_eq_true hu0 ▸ TShape.sort_eqv.1)`),
+  which is what makes the `.ctor'`/`.indTy` observation available.
+* the nullary-constructor case of adequacy's constant case
+  (`ShapeLogRelAdequacy.lean:6339`), same role, to obtain `LRS.IndTyHead`.
+
+(`Params.ctor_ty`, `SExpr.lean:2353-2368`, only re-exports the field.)
+
+**How bad it is.** `SLevel` is semantic (`SExpr.lean:50`), so `u ≠ .zero`
+means "nonzero at *some* valuation". The violation is therefore exactly the
+*identically*-Prop instantiations. That is still fatal:
+
+* A constructor's type ends in its inductive type. If the inductive is
+  `Prop`-sorted, the whole Pi type has sort `imax _ 0 = 0` — **at every level
+  instantiation**. So every constructor of `Eq`, `And`, `Or`, `Exists`,
+  `False`, `Acc`, … violates `hu0` unconditionally.
+* Universe-polymorphic constructors (`Quot.mk`, `PUnit.unit`, `PProd.mk`)
+  violate it at their Prop instantiations — the D1 record's case.
+
+**Banked** (`hu0_impossible_at_prop`, probe §G6): under type uniqueness — the
+`LogRel.ContextualRawTypeUniq` the joint L4L-16/17 route already delivers —
+*no* choice of `CtorBundle` satisfies `hu0` for a Prop-typed constructor, because
+the bundle's own equality `Γ ⊢ mkInst ls ci.type ≡ F.rhs ls : .sort F.u`
+pins `F.u` against the type's Prop typing. The wall is intrinsic.
+
+**Can the classifier dodge it?** No. `Params.pat_wf` forces
+`classify ctor = some (.ctor arity)` for any pattern in `Pat`
+(`quotPattern_forces_ctor_classification`, D1:2755, is the kernel-checked
+instance of this). Keeping a Prop inductive's iota patterns *out* of `Pat`
+then leaves `Semantic.registered` with no route for its rules: `.extra`
+needs a `Pattern.Action`, hence membership; `defn` is constant-patterns only;
+and `proofIrrel` closes only rules whose *type* is a Prop, which fails for
+every large-eliminating Prop inductive (`Eq.rec`, `Acc.rec`, `False.rec`
+have Type-valued motives).
+
+**Recommended repair — and it is cheaper than both candidates in the D1 note.**
+The D1 record offers "typing-conditional `hu0`" or "restrict `Semantic.ctor`'s
+level quantification". Both add interface surface. **Simply delete `hu0`.**
+Justification, **banked** (`propWitness_of_ctor_zero`, probe §G6): in the
+`F.u = .zero` branch the Prop typing of the constructor's type is *free* from
+the bundle's own equality (`hF.hasType.1` after rewriting). So no new field
+and no new premise is needed — the two consumption sites simply case-split on
+`F.u = .zero`, and the zero branch has all the evidence it needs.
+
+The residual obligation is confined to those two sites, and it has two
+possible resolutions. A cheap discriminating probe settles which
+(`propCtor_membership`, probe §G6a):
+
+* **(i) absorption** — in the Prop branch the observation degenerates to
+  `.bot` and the goal closes by the relation's bot law. The machinery is
+  adjacent: the same match at `ShapeLogRelAdequacy.lean:6325` already has a
+  `| bot hm => exact (LR Γ₀).bot hm` arm.
+* **(ii) contradiction** — a Prop-typed constant cannot carry a ctor-shaped
+  `LE_Interp` membership at all, in which case `hu0` was never load-bearing
+  and the deletion is free.
+
+(ii) is the ideal outcome and should be probed first. **This repair is
+16C′-owner territory and is the single highest-leverage unblock in this
+document** — it is also what unblocks D1's parked quotient half.
+
+### 5.2 Iota check discharge — the unrecorded wall
+
+`Semantic.iotaSite` must produce `Pattern.IotaReductionSite`, whose `dfs` /
+`defeqs` / `checked` fields (`Experimental/SExpr.lean:1772-1774`) assert that
+the rule's `Check` obligations hold **at the matched redex**.
+
+`gen.ruleCheck` (`Theory/Typing/InductivePattern.lean:563-582`) emits:
+* one `.defeq` per `source.nparams`, comparing the constructor-side parameter
+  argument with the recursor-side parameter argument; and
+* one `.defeq` per result index, comparing the recursor-side index argument
+  with the computed index tower applied to the captures.
+
+At an arbitrary matched redex these are **not syntactic identities** — they
+are forced only semantically, by the major premise's type. `IotaTyping`
+(`SExpr.lean:1700-1714`) supplies two typings of the constructor application:
+at `ctorResultType` (from `ctorSpine`) and at the recursor's major-premise
+domain (from `recSpine`). Reconciling them gives `I recParams recIdx ≡
+I ctorParams ctorIdx`; extracting the argument equalities from that needs
+**injectivity of a stuck inductive-type application** — Church–Rosser /
+L4L-18A′ strength, exactly the strength the D1 record cites as obstruction 3
+for `quotCheck`.
+
+**The semantic side cannot help.** The logical relation realizes `indTy`
+arguments at `.bot` (`ShapeLogRel.lean:9244`,
+`rargs := .replicate args.length .bot`), so it tracks no argument information
+at all by design.
+
+**This is unrecorded and it is a D2 risk, not just a generic-construction
+risk.** All three fixture sites end `dfs := []; checked := by simp` because
+Nat has neither parameters nor indices. D2's remaining work is List and the
+PatTree/PatForest blocks — List has one parameter, so D2 hits this the moment
+its `Semantic` plumbing is attempted. **Recommendation: raise this into the
+D2 line of the completion plan now**, before D2 spends effort discovering it.
+
+Staged as `iotaCheck_param` in probe §G7.
+
+### 5.3 `Semantic.structureEta` — the SExpr layer is asked to prove a primitive
+
+Established facts (verified this pass):
+
+* `VStructEta.WF` (`Theory/Typing/Basic.lean:115-133`) has exactly two
+  fields, `familyType_closed` and `rebuild_hasType`. It is a **subject-
+  reduction certificate only**; it contains no equality.
+* The eta equation enters *exclusively* through the primitive constructors
+  `VEnv.IsDefEq.structEta` (`Theory/Typing/Basic.lean:59-69`) and
+  `IsDefEqStrong.structEta` (`Theory/Typing/Strong.lean:74-87`), both gated
+  on `env.structEtas rule`.
+* SExpr's `IsDefEq` (`SExpr.lean:1260-1281`) and `IsDefEqStrong` (`:1905`)
+  have **no** `structEta` constructor — which is exactly why
+  `Params.Semantic.structureEta` and `Params.StructureEtaSound` (`:1796`)
+  exist as fields.
+* Every discharge in the tree is vacuous (`natStructureEtaSound` D0:1141,
+  `d0StructureEtaSound` D0:5594, `d1StructureEtaSound` D1:1123, and the three
+  `Semantic.structureEta` fields).
+* `VEnv.hasStructureEta_of_registry` (`Theory/Projection.lean:2076`) is
+  registry *consumption*, not derivation; its own doc comment
+  (`Projection.lean:1790-1802`) says the equality is what the certificates do
+  not derive.
+* No concrete `VStructEta.WF` value is constructed anywhere in the repo.
+
+So the field asks the SExpr judgment to *prove* an equation that Theory
+*postulates*. Structure eta does not follow from iota at a stuck major (that
+is the whole point of the rule), so it is not derivable as stated.
+
+**Encouraging counterweight:** the semantic ingredient is already built.
+`Shape.ctor'` (`ShapeLogRel.lean:817`) collapses an all-bot
+structure-constructor shape to `.bot` **exactly when `IsStruct c`**, i.e.
+when `classify c = some (.etaCtor ..)` (`:815`), and `WShape` carries the
+`IsStruct n → ListNonZero l` side condition (`:856`, `:974`). The
+`.etaCtor` classification (`SExpr.lean:10`) is otherwise unused in the entire
+tree. The design clearly anticipated eta support and stopped one layer short.
+
+**Recommended route:** mirror Theory's primitive on the SExpr side (add
+`structEta` to `IsDefEq`/`IsDefEqStrong`), prove the adequacy case from the
+`Shape.ctor'` bot-collapse, and `Semantic.structureEta` then becomes a
+transport like every other field. This is a scoped sub-development with
+existing semantic support — but it is an interface change to a module the
+16C′ owner is actively editing, so it is a decision, not a task.
+
+---
+
+## 6. Why conditional instances do not reach the target
+
+The commission asks whether a partial instance (non-Prop fragment) could
+suffice, "checking what `sort_invS`'s proof actually consumes from
+`Semantic.ctor`". Measured answer: **it consumes it everywhere, and the
+restriction cannot be moved onto the goal.**
+
+* `sort_invS` (`ShapeLogRelAdequacy.lean:7064-7076`) calls
+  `SExpr.sort_inv` → `sort_inv_of_adequacy` with `LR.adequacyAt Γ hΓ 1`.
+  `adequacyAt` is a theorem about **all** derivations at that level, so its
+  proof needs the constant case — hence `Semantic.ctor` and `hu0` — for
+  every ctor-classified constant in the environment, whatever the goal.
+* `sort_invS` also calls `(h.strong Params.henv hΓ).mkS`, and
+  `IsDefEqStrong.mkS`'s `constDF` case (`SExpr.lean:2117-2125`) instantiates
+  `Semantic.ctor` at **every** constant node of the *input* derivation, which
+  is arbitrary — a derivation of `sort u ≡ sort v` may route through any
+  constant in the environment.
+
+So a conditional instance yields exactly: *for any WF environment with no
+Prop-sorted inductive, no Prop-instantiable constructor, no parameterised or
+indexed inductive, and an empty eta registry, `sort_inv` holds.* That is the
+D0–D2 fixture ladder restated, not a public theorem. It is worth having as a
+**staging artifact** (it is what D2/D3 actually deliver), but it must not be
+sold as closing `IsDefEqU.sort_inv`.
+
+Probe §G9 (`NoPropCtor`, `conditionalInstance`) types this so the claim is
+stated rather than implied.
+
+---
+
+## 7. Staged obligations, as Lean statements
+
+All are typed in `plans/probes/probeG-generic-instance.lean` (green).
+"Banked" = proved there at `[propext, Quot.sound]`.
+
+| # | Obligation | Probe name | Difficulty | Depends on |
+|---|---|---|---|---|
+| **R0** | promotion is one instance wide | `sort_inv_of_generic` | **BANKED** | — |
+| **R1** | generic syntax transport (replaces ~1200 lines of D-ladder boilerplate) | `transportLevel`, `transportExpr`, `transportLevel_transportLevel` | **BANKED** | — |
+| **R2** | the per-step extension theorem | `Step`, `StepObligations`, `Semantic.step` | mechanical induction, ~1 week | R1 |
+| **R3** | `classify` + `pat_wf` from block certificates | `blockClassify`, `blockClassify_pat_wf` | needs new lemma (combinatorial) | — |
+| **R4** | `ExtSeparation` from the history | `extSeparation_intra`, `extSeparation_inter` | needs 6 new lemmas + `nodup_parts` visibility; pure bookkeeping | §4 gaps |
+| **R5** | `defn` rung at `uvars > 0` | `step_def` | small, mechanical | R2 |
+| **R6** | `hu0` deletion + Prop branch at 2 sites | `propWitness_of_ctor_zero` (**BANKED**), `hu0_impossible_at_prop` (**BANKED**), `propCtor_membership` (open) | **interface decision** — 16C′ owner | — |
+| **R7** | iota check discharge for parameters/indices | `iotaCheck_param` | **BLOCKED — L4L-18A′ strength** | stuck-application injectivity |
+| **R8** | SExpr `structEta` primitive + adequacy case | `structureEta_underivable` | **interface decision**, then a scoped development | — |
+| **R9** | generic `registered` tower descent + generic `iotaSite` | `genericInstance_of_WF'`, `step_induct` | the bulk (weeks) | R2–R6, R7, R8 |
+
+**Attackable today, with no interface decision and no other milestone:**
+R1 (done), R2, R3, R4, R5. Together these are the whole non-semantic half of
+the construction, and R1+R2 pay for themselves immediately on D2/D3/D4.
+
+**Blocked on a decision the 16C′ owner must take:** R6, R8.
+**Blocked on another milestone:** R7 (18A′).
+
+---
+
+## 8. Recommendation for the pending plan decision
+
+**Neither option in the plan's question is right; take the third door.**
+
+1. **Not D4's endpoint.** D4 is currently written as "registered structure
+   eta from the L4L-15B registry" — but §5.3 shows that line is itself an
+   interface change plus a scoped semantic development, not plumbing. Loading
+   the generic construction (which contains two further walls, one of them
+   18A′-strength) onto D4's exit makes D4 unschedulable.
+
+2. **Not a named 16E step.** 16E is measured in days
+   (`plans/l4l-16e-promotion-map.md`). This is months, and two of its
+   obligations are interface decisions in modules 16E does not own.
+
+3. **Not "conditional".** §6: a conditional instance cannot reach
+   `IsDefEqU.sort_inv`, only the fixture-shaped restatement.
+
+**Do this instead** — the same move already recommended for `weakN_iff` in
+`plans/l4l-16-weakn-design.md`:
+
+* **Re-scope the arbitrary-environment `IsDefEqU.sort_inv` promotion off the
+  16E gate** into a new named milestone (suggested: **L4L-16F "live
+  instance"**, or fold into the L4L-19 slot). 16E then exits on: the SExpr
+  statements going clean, the module moves, the guard re-pins, and the
+  *fixture-instantiated* endpoints (`d0SortInvS`, `d1SortInvS`, D2…).
+* **16E's allowlist exit count does not shrink by the `sort_inv` row.**
+  Combined with the `weakN_iff` re-scope already recommended (which lands 16E
+  at 19 rather than 17), the `sort_inv` row stays on the list too. The
+  promotion map's gate table needs that correction before execution.
+* **Add R1+R2 to the D-ladder now, ahead of D2.** They are banked/mechanical
+  and they delete a repeated ~600-line-per-rung cost that D2, D3 and D4 would
+  otherwise each pay again.
+* **Raise §5.2 (iota check discharge) into the D2 line immediately.** D2's
+  remaining work is "registry consumption along D1's template"; that template
+  never exercised `checked`, and List's parameter check will stop it. Better
+  to know before the effort starts.
+* **Put R6 (`hu0` deletion) in front of the 16C′ owner as a one-line
+  decision** with the banked evidence: the Prop witness is free, so the
+  repair costs a case split at two sites and no new interface surface; and it
+  simultaneously unblocks D1's parked quotient half.
+
+**Two-strikes note.** No formalization attempt in this pass hit a second
+strike: R0, R1 and the two `hu0` facts went through on the first attempt; the
+one draft error (assuming `Pattern.RHS` needed transport) was corrected by
+the elaborator on the first re-run, and the correction *reduced* the staged
+work. Everything else in §7 is stated, not attempted, by design.
+
+---
+
+## 9. Appendix — measured citations
+
+Interfaces: `Experimental/SExpr.lean:24-45` (`Params`), `:1890-1897`
+(`CtorBundle`, `hu0`), `:1964-2050` (`Params.Semantic`), `:2056-2086`
+(`IotaReductionSite.action`), `:2091-2194` (`IsDefEqStrong.mkS`),
+`:2200-2235` (`closedHasTypeStrong`), `:1700-1774` (`IotaTyping`,
+`IotaRule`, `IotaReductionSite`), `:1783-1791` (`Pattern.Action`),
+`:1796-1807` (`StructureEtaSound`), `:217` (`SExpr` is `[Params]`-indexed).
+
+Gate: `Experimental/ShapeLogRelAdequacy.lean:7001-7076`.
+
+`hu0` consumers: `Experimental/ShapeLogRel.lean:9208-9251`,
+`Experimental/ShapeLogRelAdequacy.lean:6325-6345`.
+
+Fixtures: `SExprParamsD0.lean:514-546` (`natParams`/`d0Params`),
+`:1141-1145`, `:1597`, `:1954-2578`, `:2898-5497`, `:5497-5591`
+(`natSemantic`), `:6033`, `:6116`, `:6146`, `:6199-6829`, `:6875-6903`
+(`d0Semantic`), `:6904-6952`. `SExprParamsD1.lean:245-474` (pattern layer),
+`:475-1120` (transport), `:1121-2651` (semantic certificates),
+`:2703-2755` (quot obstruction record), `:2755` (forcing lemma).
+
+Union engine: `Theory/Typing/InductivePatternEnv.lean:109-236` (head
+separation), `:249-336` (`CertifiedExtension`, `quot`), `:347` (`iotaExtension`),
+`:520-546` (`AssembledPat`), `:558-567` (`ExtSeparation`), `:570-748` (four
+laws), `:760` (`separation_is_necessary`).
+
+Block certificates: `Theory/Typing/InductivePattern.lean:222` (`blockGeneratedNames_nodup`),
+`:287-289` (`rulePattern`), `:430` (private `nodup_parts`), `:443-524`
+(injectivity family), `:541-582` (`captureArgs`, `ruleRHS`, `ruleCheck`),
+`:607-726` (`IotaPat` + four laws).
+
+Circularity trap: `Theory/Typing/InductivePatternWF.lean:543` and its axiom
+pin at `:942-949`; `Theory/Typing/UniqueTyping.lean:167` (`IsDefEqU.trans`),
+`:13` (`uniq`), `Theory/Typing/Injectivity.lean:11` (`sort_inv`, sorried).
+
+History: `Theory/Typing/Env.lean:19-67`, `Theory/VDecl.lean:22-29`,
+`Theory/Typing/EnvLemmas.lean:88` (`WF.ordered`).
+
+Structure eta: `Theory/VEnv.lean:21-64, 170-199`,
+`Theory/Typing/Basic.lean:59-69, 115-133`, `Theory/Typing/Strong.lean:74-87`,
+`Theory/Projection.lean:1790-1802, 2076-2091`,
+`Experimental/ShapeLogRel.lean:815-856, 974`.
+
+Freshness: `Theory/VEnv.lean:184-187`, `Theory/Typing/Lemmas.lean:197, 220`,
+`Theory/Typing/EnvLemmas.lean:27`, `Theory/Typing/InductiveLemmas.lean:13828,
+14091-14180`, `Theory/Typing/InductivePatternFixtures.lean:216-234`.
diff --git a/plans/l4l-16-registered-pi-design.md b/plans/l4l-16-registered-pi-design.md
new file mode 100644
index 00000000..63cdadcb
--- /dev/null
+++ b/plans/l4l-16-registered-pi-design.md
@@ -0,0 +1,332 @@
+# L4L-16 — the registered-endpoint narrowing of the 16C′ leaf, measured
+
+**Date:** 2026-08-15.  **Probe:** `plans/probes/probeU-regpi.lean` (green:
+`lake env lean` exit 0, zero sorries, all 19 `#print axioms` checks land on
+`[propext, Quot.sound]` or `[propext, Classical.choice, Quot.sound]` — no
+`sorryAx`).  The probe imports `Lean4Lean.Experimental.ShapeLogRel` **only**,
+so non-circularity with respect to adequacy is structural, as in probeS/probeT:
+`LR.AdequacyAt`, `LR.ContextualAdequacyAt(Depth)` and every `*.of_adequacy*`
+are not in its import closure at all.  No banned input is touched (no
+`ParRedSDefeq`/`CRComplete`/`PiStandard`/`PiEdgeInv`/`SubjectRedS`/`PiEdgeObs`,
+no `WHRedS.defeq`, no `TypeDefEqPath.collapse`/`RawTypeUniq`, no Theory
+`ParRed.defeq`/`StRed.triangle`; the axiom closures certify this).
+
+**Question.**  probeT closed the *stratification* axis of the 16C′ leaf
+(`LR.iotaWitnessStep`, ADQ:8553, sorry at :8583) by machine refutation.  Its
+recommendation was the remaining unmeasured axis: the leaf's residual
+`LRS.PiPathInv` (SLR:11417) inverts Pi along a `TypeDefEqPath` with **both**
+endpoints arbitrary, but the leaf's *live* demands may be narrower — one
+endpoint pinned to a **registered telescope**, i.e. certificate data
+(`SExpr.mkInst ls ci.type` and the `CtorBundle.rhs` telescope
+`Ts.foldr .forallE …` it is definitionally equal to, SExpr:1899, 1977-1982).
+This is the sanctioned voucher source: "Whatever depth bound a leaf producer
+needs must come from its own registered-rule certificates" (ADQ:8514-8515),
+and the roadmap flagged this residual's subject as registered — "the first
+residual a generation-side argument can attack" (roadmap.md:708-715).
+
+---
+
+## Verdict in one line
+
+**The narrowing is real, non-vacuous, and closes exactly one of the leaf's two
+`PiPathInv` sites — the whole *interior* of the constructor chain, which is the
+unbounded one — and provably does **not** close the other (`rootRed`, the two
+root callbacks), for two independent measured reasons.  The narrowed
+proposition itself is *not* easier to prove: the registered class is not closed
+under a single path edge, so the decoration dies at the first `trans` of the
+path exactly as the depth decoration did (probeT's `transMiddleCertAt_false`).
+Net: the registered axis moves the leaf's residual from "Pi inversion at
+arbitrary paths, everywhere" to "Pi inversion at arbitrary paths, at two named
+root callbacks" — a genuine narrowing of *scope* with no reduction of
+*content*.**
+
+---
+
+## (i) The narrowed proposition
+
+```lean
+inductive RegTele : Nat → SExpr → Prop where          -- probeU Part 1
+  | base : RegTele 0 (args.foldr (fun a f => f.app a) (.const I ls))
+  | pi   : RegTele k B → RegTele (k + 1) (.forallE A B)
+
+def LRS.PiPathInvReg : Prop :=                        -- probeU Part 2
+  ∀ {Γ k A B A' B' s}, Ctx.WF Γ → RegTele (k + 1) (.forallE A B) →
+    TypeDefEqPath Γ (.forallE A B) (.forallE A' B') s →
+    ∃ u v, TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+```
+
+`RegTele k T` is *exactly* the syntactic shape of `CtorBundle.rhs` (SExpr:1899)
+with the tower length exposed: a `k`-ary Pi tower over a constant-headed
+application spine.  `CtorBundle.rhs_regTele` (probeU) certifies the connection
+to the real certificate; `LRS.PiPathInvReg.of_piPathInv` certifies that nothing
+has been strengthened.  The Prop is `LRS.PiPathInv` plus **one** side condition
+— no depth index, no universe alignment, no collapse — so it is exactly the
+narrowing the brief asked for and nothing else.
+
+Three facts about the class, all machine-checked, that make it usable:
+
+* **closed under substitution** (`RegTele.subst`), hence under the `inst` a
+  spine walk performs at every layer (`RegTele.inst`) — `SExpr.subst` is
+  structural on `.forallE`/`.app` and fixes `.const` (SExpr:520-526), so the
+  tower length, head constant and levels all survive;
+* **invertible** (`RegTele.pi_inv`): a positive member *is* a syntactic Pi
+  whose codomain is again in the class one arity lower;
+* **the base is load-bearing**: the class excludes Pis whose iterated codomain
+  is a sort (`RegTele.not_forallE_sort`), a `.lam`-headed redex
+  (`RegTele.zero_not_app_lam`), etc.  Dropping the base condition (a bare
+  "k-ary Pi tower") would make the side condition **vacuous at the last
+  layer** — `PiTower 1 (.forallE A B)` is `True` — i.e. would silently restate
+  the full leaf.  The narrowing is precisely a *data-telescope* restriction.
+
+---
+
+## (ii) The kill-shot check — run first, outcome NEGATIVE (the narrowing survives)
+
+The cheapest way for this axis to be worthless: if the
+`LRS.PiPathInv → LRS.ParRedSDefeq` direction of
+`LRS.piPathInv_iff_parRedSDefeq` (SLR:16210) needed only the registered class,
+then `PiPathInvReg` would inherit the ladder's interderivability with the leaf
+and be no cheaper.
+
+It does not.  `ParRed.defeq_of_piPathInv` (SLR:16128) charges `piInv` **exactly
+once**, at SLR:16154, on the path returned by `IsDefEqStrong.lam_inv'`, whose
+left endpoint is the *abstraction's own declared Pi* — the annotation the term
+carries — and whose right endpoint is the application's Pi.  `probeU`'s
+`betaSite_outside_regTele` realizes that site verbatim from the banked witness
+`betaSort_domain_unconstrained` (SLR:16302), in the **empty context with no
+environment assumptions**, and proves **both** endpoints outside the class at
+**every** arity (their codomain is a sort; a registered telescope bottoms out in
+a constant-headed spine).
+
+So the registered narrowing is a genuinely different question from the one
+`piPathInv_iff_parRedSDefeq` closed, and it is not vacuous as an escape.  (It is
+also not refutable: `PiPathInvReg` is *implied* by the leaf, so unlike every
+Prop probeT closed, the discipline that applies to it is non-vacuity, not
+falsity — see the `U-vac` row below.)
+
+---
+
+## (iii) The live sites, measured
+
+The complete inventory of `piInv` *uses* in the tree (grep `piInv hΓ`), split
+by whether they are on the leaf path:
+
+| # | site | file:line | on leaf path? | registered? |
+|---|------|-----------|---------------|-------------|
+| 1 | `SpineWF.result_path`, one per spine layer | SLR:11440 | **yes** (`ctorRetype`) | **YES** — closed, see (iv) |
+| 2 | `WHRed.defeq_of_piPathInv`, `beta` case | SLR:11530 | **yes** (`rootRed`) | **no** — measured |
+| 3 | `WHRed.defeq_of_piPathInv`, `extra` case (via `constSpineTypeUniqPath`) | SLR:11542 | **yes** (`rootRed`) | **no** — measured |
+| 4 | `LRS.PatStep.of_piPathInv` | SLR:16093 | no (CR ladder) | no (same as 3) |
+| 5 | `ParRed.defeq_of_piPathInv`, `beta` case | SLR:16154 | no (CR ladder) | no (the kill-shot) |
+
+The leaf path is: leaf `LR.iotaWitnessStep` (ADQ:8553) → `LR.CoherentIotaLeafStep`
+(ADQ:7323, whose status note ADQ:7309-7322 names the fold) →
+`LRS.CtorDefEq.foldRaw_of_majorChainAnchorStep` (ADQ:1191) →
+`LR.MajorChainAnchorStep` (ADQ:1105), whose two fields are `ctorRetype`
+(:1106-1111) and `rootRed` (:1112-1115).  Both are live; `of_piPathInv`
+(ADQ:1157) discharges them from one general leaf.
+
+**Site (a) — `ctorRetype`, the chain interior.**  `LRS.CtorRetype` ⟸
+`LRS.CtorExact.retype_of_ctorSpineTypeUniqPath` (SLR:11564) ⟸
+`LRS.CtorSpineTypeUniqPath` (SLR:11196).  Its subject is a *classified
+constructor* spine with its head typing and `SpineWF` certificate retained.
+**Both** endpoints of the demanded path are types of the *same* constant-headed
+spine, so both head types are pinned to the environment's own
+`SExpr.mkInst ls ci.type` by `HasTypeStratifiedS.to_core_path` (SLR:11255) —
+this is what `LRS.constTypeUniqPath` (SLR:11389) already exploits — and
+`Params.Semantic.ctor` (SExpr:1977) turns that into the syntactic telescope
+`F.rhs ls` of the constructor's own arity (`CtorBundle.hlen`, SExpr:1895).
+So a registered endpoint is available *by construction* at this site.  This is
+usage-unbounded: once per native link of the chain (×3 inside
+`retype_of_ctorSpineTypeUniqPath`) and once per spine layer inside each.
+
+**Site (b) — `rootRed`, the two root callbacks.**  `LRS.CtorView Γ₀ M X`
+(SLR:11009) constrains only the *target* of the weak-head reduction; the root
+`M` is the observation's own subject, arbitrary.  Two independent measurements,
+both machine-checked:
+
+* **(b-i) the `beta` case is unconstrained.**  `rootRed_meets_beta` (probeU):
+  for every classified nullary constructor, `(fun _ : T => c) a` has a
+  constructor view through a β step, with **no typing and no environment
+  assumptions beyond the classification** — so the β case of
+  `WHRed.defeq_of_piPathInv` is live at `rootRed`, at an abstraction domain
+  `T` the view says nothing about.  Combined with `betaSite_outside_regTele`
+  (§(ii)), the Pi endpoints there are outside the class.  This is the same
+  obstruction the *sort* narrowing hit (roadmap.md:799-803), and for the same
+  structural reason: sort-typedness constrains the result, registration
+  constrains the head — neither constrains an abstraction's domain annotation.
+* **(b-ii) the `extra` case has no telescope to anchor on.**
+  `extraSite_head_not_isCtor` (probeU): every redex a `Pattern.Action`
+  contracts is a spine over a constant that is **provably not a constructor**
+  (pattern heads are `symb`-classified at top level: `Pattern.WF` SExpr:20 +
+  `Params.pat_wf` SExpr:31, via `Pattern.MatchesS.head_spine` SExpr:899 and the
+  new `Arity.head_wf`).  `Params.Semantic.ctor` is the **only** field of the
+  semantic bridge that produces a telescope and it is gated on
+  `CtorBundle.IsCtor` (`symb_not_isCtor`).
+
+**Semantic-bridge field inventory** (asked for explicitly).  `Params.Semantic`
+(SExpr:1964-2050) has exactly six fields: `structureEta`, `ctor`, `defn`,
+`iotaRule`, `iotaSite`, `registered`.  **The lemma-(C)-style coherence field
+does not exist** — there is no field asserting that the stripped lhs head of a
+registered equation classifies as a symbol, and no field giving a telescope
+normal form for a `symb`-classified constant.  `defn` covers zero-arity
+patterns only, and supplies a *value*, not a type telescope.
+
+---
+
+## (iv) The result: site (a) closes from the narrowed Prop alone
+
+`LRS.CtorSpineTypeUniqPath.of_piPathInvReg` (probeU Part 3), and with it
+`LRS.CtorAnchorDisciplineAt.of_piPathInvReg` and
+`LRS.CtorChain.foldRaw_of_piPathInvReg` — the whole interior of the
+constructor chain — is now discharged from `LRS.PiPathInvReg`, where before it
+spent the general leaf (`LRS.CtorSpineTypeUniqPath.of_piPathInv`, SLR:11478).
+
+The proof is a **restructuring**, not a trick, and the restructuring is the
+transferable content of this measurement:
+
+* `SpineWF.result_path` (SLR:11430) inducts on *one of the two spine
+  derivations*.  Its `conv` case moves that spine's head type off the
+  registered telescope at the first opportunity, so the left endpoint of every
+  layer inversion is an arbitrary Pi.  That is why the current proof needs the
+  general leaf.
+* `regSpine_result_uniq` (probeU) never inducts on a spine derivation.  It
+  inducts on the **argument list**, keeping the registered telescope as a fixed
+  anchor and approaching *both* spines from it with `SpineWF.cons_path`
+  (SLR:11322) / `nil_path` (SLR:11305).  Every layer inversion then has the
+  telescope's own tail on the left, registered by construction, because the
+  class is closed under the `inst` each layer performs.  The arity side
+  condition is discharged by the bundle's own `hlen`.
+
+Consequences worth recording:
+
+* the narrowing removes the depth question from this site entirely — neither
+  the Prop nor the walk mentions a stratification index, consistent with
+  probeT's finding that the depth axis has nothing to offer;
+* nothing here consumes a classification of the *other* spine, a universe
+  alignment, or a path collapse;
+* the leaf's remaining general-`PiPathInv` demand drops from
+  "chain length × spine length" uses to **exactly two** — the root callbacks
+  (SLR:11755-11758 already names them "the only remaining raw inputs").
+
+---
+
+## (v) The proof attempt for `LRS.PiPathInvReg`, and its obstruction
+
+Two angles were tried (two-strikes discipline), and both fail at the same
+place.
+
+**Angle 1 — walk the path from the registered end.**  The only path-walking
+argument in the tree is `LRS.PiPathInv.of_piEdgeObs` (SLR:15281): it maintains
+the invariant "the current vertex weak-head reduces to a Pi" at *every* vertex,
+and consumes `LRS.PiEdgeObs` at each edge.  **`regClass_not_edge_closed`
+(probeU) refutes the registered analogue of that invariant**: for *any* type
+`T` in *any* context, with no environment assumptions, the identity β-redex
+`(fun _ : Sort u => #0) T` is `IsDefEq`-equal to `T` at its own universe and is
+outside the class at every arity.  So the walk loses its side condition at the
+first edge, and the input it would need at the second is the general
+`LRS.PiEdgeObs` again.
+
+**Angle 1′ — induct on the path structure instead.**
+`regPath_interior_unregistered` (probeU) sharpens this to the induction that
+would have to work: `TypeDefEqPath` is generated by `single` and `trans`, and
+`trans`'s middle vertex is existential.  Every registered Pi sits on a path
+whose *interior* is outside the class, so a structural induction hands its
+inductive hypothesis a non-registered left endpoint at the first `trans` split,
+whichever endpoint it starts from.  **This is the registered-axis analogue of
+probeT's `LRS.transMiddleCertAt_false`**: both axes decorate the *endpoints* of
+a `TypeDefEqPath`, and both are defeated by the same structural fact — the
+relation's `trans` retains nothing about the middle.
+
+**Angle 2 — a registered single-edge inversion.**  Blocked upstream, by
+inspection of what a single edge costs: the general single-edge Prop
+`LRS.PiEdgeInv` has one producer, `LRS.PiEdgeInv.of_crLadder` (SLR:15506),
+which spends `LRS.CRComplete` + `LRS.ParRedSDefeq`; registration decorates the
+endpoint, not the edge's derivation, so it removes no case from that proof.
+The registered analogue of the head-transport factor would be a
+`reduce_const`-shaped fact, and SLR:15762-15768 already records that Theory's
+`reduce_*` family stops at `reduce_sort`/`reduce_forallE` — `LRS.IndTyHeadNorm`
+(SLR:15769) is exactly this missing fact, still open.
+
+**Parked as U-b1** (open sub-question, moot for the verdict): whether a
+*neutral-base* generalization of `RegTele` (allowing `bvar`-headed bases, which
+is what recursor telescopes like `… → C t` need) plus a new `Params.Semantic`
+telescope field for `symb`-classified constants would extend the narrowing to
+site (b-ii).  Two observations bound it: the generalization keeps the kill-shot
+(a sort base is still excluded), but it does **not** help site (b-i), and it
+needs a new generation-side field constructed in every `Params.Semantic`
+instance (including `SExprParamsD0/D1/D2`).
+
+---
+
+## Staged obligations (all landed in probeU unless marked)
+
+| # | Statement (one line) | Status |
+|---|---|---|
+| U0 | `RegTele` is the `CtorBundle.rhs` shape, closed under substitution/`inst`, invertible, and excludes sort/redex-based Pis | probe-proved (`CtorBundle.rhs_regTele`, `RegTele.subst`, `.inst`, `.pi_inv`, `.not_forallE_sort`, `.zero_not_app_lam`) |
+| U1 | `LRS.PiPathInvReg` is a weakening of the leaf (nothing strengthened) | probe-proved (`LRS.PiPathInvReg.of_piPathInv`) |
+| U2 | **Kill-shot:** the `PiPathInv → ParRedSDefeq` β site is outside the class at every arity, in the empty context | probe-proved (`betaSite_outside_regTele`) — narrowing survives |
+| U3 | Two spines reached from one registered telescope have path-equal results, spending only `PiPathInvReg` | probe-proved (`regSpine_result_uniq`) |
+| U4 | **Site (a) closes:** `LRS.CtorSpineTypeUniqPath` from `PiPathInvReg` alone | probe-proved (`LRS.CtorSpineTypeUniqPath.of_piPathInvReg`) |
+| U4′ | …and with it the leaf-side consumers: the per-leaf anchor discipline and the whole chain-fold interior | probe-proved (`LRS.CtorAnchorDisciplineAt.of_piPathInvReg`, `LRS.CtorChain.foldRaw_of_piPathInvReg`) |
+| U5 | **Site (b-i) does not close:** a constructor view is reachable through a β step with no environment assumptions; its Pi endpoints are unregistered | probe-proved (`rootRed_meets_beta` + U2) |
+| U6 | **Site (b-ii) does not close:** every `Pattern.Action` redex head is provably not a constructor, so no telescope exists to anchor the walk | probe-proved (`Arity.head_wf`, `symb_not_isCtor`, `extraSite_head_not_isCtor`) |
+| U7 | The semantic bridge has no head-classification coherence field and no `symb` telescope field (six fields, enumerated) | measured by inspection (SExpr:1964-2050) |
+| U8 | **The narrowed Prop is not easier:** the class is not closed under one path edge, and every registered Pi has unregistered path interiors | probe-proved (`regClass_not_edge_closed`, `regPath_interior_unregistered`) |
+| U-vac | Non-vacuity: the class is inhabited, and `PiPathInvReg`'s hypothesis is inhabited **off the diagonal** (environment-conditional, like `LRS.indTyHead_nonvacuous`) | probe-proved (`regTele_nonvacuous`, `LRS.piPathInvReg_nonvacuous`) |
+| U-b1 | Neutral-base generalization + a `symb` telescope field for site (b-ii) | **parked** — moot for the verdict (site (b-i) fails regardless) |
+
+---
+
+## (vi) Bottom line, and the single question that remains
+
+**Leaf closable by the registered-endpoint narrowing: NO — but the axis is not
+refuted, and it is not empty either.**  Unlike the stratification axis (probeT:
+refuted at every depth) and the sort narrowing (banked counterexample), the
+registered axis *does* buy something checkable: the entire interior of the
+constructor chain — every native link, every layer of every spine — now costs
+only `LRS.PiPathInvReg`, whose registered endpoint is supplied by the
+constructor's own bundle.  What it does not buy is a cheaper proof: the
+decoration is destroyed by the first path edge, for the same structural reason
+the depth decoration was destroyed by `trans`.
+
+**What is left of the leaf after both axes are closed** is exactly two root
+callbacks, and one question about them:
+
+> **Can `LRS.CtorView` be upgraded to a *typed* view — carrying
+> `IsDefEq Γ M X A` alongside the bare `WHRedS Γ M X` — so that `rootRed`
+> dissolves the way the chain interior dissolved in the 2026-08-15 repair?**
+
+That is the exact analogue of the repair that killed the interior half: the
+interior was not *proved*, it was **retained** (the reconciliation moved into
+the `LRS.CtorExact` certificate).  The root views are the last place where a
+reduction enters the fold with no typing attached.  The measurement to run is
+scoped and additive-or-not-decidable in one probe:
+
+* the views are produced by `LRS.CtorDefEq.toChain` (SLR:11979), whose `whr`
+  and `unwhr` cases (SLR:11994-11995) pass through the bare reductions stored
+  by the `LogRel` closure law `whr` (SLR:10064), an **iff** — so the upgrade
+  must supply typings in *both* directions, which is the real risk;
+* the evidence that it may be affordable: at the adequacy producer the
+  reduction always arrives typed (e.g. ADQ:8496-8498 builds it from
+  `SExpr.WHRed.extra action`, whose `action.sound` is the typing), and
+  `WHRed.defeq_of_piPathInv`'s non-β, non-`extra` cases (`app`, `major`) are
+  already inversion-free;
+* if the upgrade lands, the leaf's **entire** residual becomes
+  `LRS.PiPathInvReg` — at which point this document's U8 becomes the only wall
+  left, and the honest cost of the leaf is the semantic content the roadmap
+  already names (sort/Pi disjointness + standardization) with no structural
+  shortcut remaining;
+* if it does not, `rootRed` is general weak-head subject reduction
+  (`LRS.SubjectRedS` restricted to constructor targets), which
+  `LRS.piPathInv_iff_parRedSDefeq` has already shown is interderivable with the
+  leaf — i.e. the leaf's cost is unchanged and the map is complete.
+
+**Single next action:** probe the *typed constructor view* — restate
+`LRS.CtorView` with a retained `IsDefEq Γ M X A`, check whether
+`LRS.CtorChain`/`toChain`/`foldRaw_of_anchorDiscipline` still close over it,
+and measure whether every producer of a view on the leaf path (in particular
+the `whr`/`unwhr` closure laws of `LogRel`, SLR:10064-10065, in **both** directions)
+can supply the typing.  Do **not** re-open the stratification axis (probeT) or
+the sort narrowing (banked); and do not re-attempt `LRS.PiPathInvReg` by any
+path-structural induction (U8).
diff --git a/plans/l4l-16-sort-inversion-decision.md b/plans/l4l-16-sort-inversion-decision.md
new file mode 100644
index 00000000..a0e88f8f
--- /dev/null
+++ b/plans/l4l-16-sort-inversion-decision.md
@@ -0,0 +1,269 @@
+# L4L-16 sort-inversion route decision
+
+Date: 2026-08-12
+
+Status: route selected and prerequisite interface landed. The post-v4.33
+spike selected the semantic route; L4L-18B completed its prerequisite
+proof-carrying extension interface on 2026-08-12, so L4L-16 is now active.
+This note does not weaken the theorem, add an assumption, or change the
+accepted trust closure.
+
+## Gate theorem
+
+The only proof gate for this milestone is the existing live statement in
+`Theory/Typing/Injectivity.lean`:
+
+```lean
+theorem VEnv.IsDefEqU.sort_inv
+    (henv : VEnv.WF env)
+    (hΓ : OnCtx Γ (env.IsType U))
+    (h1 : env.IsDefEqU U Γ (.sort u) (.sort v)) : u ≈ v
+```
+
+The current declaration is still admitted.  It is one of the 16 proof-debt
+declarations in `Audit/SorryFrontier.lean`; therefore the compiled allowlist
+remains at 22 entries (16 proof declarations plus six deliberately rejected
+kernel fixtures).
+
+The accepted exit closure is the ordinary Theory baseline only: any subset
+of `propext`, `Classical.choice`, and `Quot.sound`.  In particular,
+`sorryAx`, a generated environment oracle, or a project-specific pattern
+axiom is not an acceptable bridge.
+
+## Route 1: shape logical relation
+
+Decision: retain this as the technically credible long-term route, but do
+not merge the fetched experimental branch as an L4L-16 proof.
+
+The semantic idea is validated by the completed companion development
+`domain-semantics-lean`: finite shape approximations prove definitional
+inversion in the presence of non-normalizing fixed points and eta.  The
+lean4lean `logrel` branch is an earlier version extended with constants and
+rewrite patterns.  Its endpoint theorem is the right shape, but its live
+closure is not acceptable:
+
+```text
+Lean4Lean.SExpr.sort_inv
+  [propext, sorryAx, Classical.choice, Quot.sound,
+   Lean4Lean.SExpr.Params.extra_pat]
+```
+
+The post-sync closure was reproduced by building
+`Lean4Lean.Experimental.UniqueTyping` and printing the dependencies.  The
+remaining assumptions on the path are concrete:
+
+1. `SExpr.IsDefEq.strong` is admitted.  Its constructor case needs the
+   classification/type bridge below.
+2. `SExpr.IsDefEqStrong.defeq` is admitted.
+3. `Params.ctor_ty` is admitted; the current `Params` classification has no
+   proved connection from a constructor classification to the translated
+   constant type required by `CtorBundle`.
+4. `LR.adequacy` has one live admitted branch: constant adequacy.
+5. `Params.extra_pat` is a project axiom rather than a class field or a
+   derived environment theorem.
+6. The unmerged VExpr-to-SExpr bridge from PR 37 translates the pre-eta
+   equality judgment only.  It predates the live `IsDefEq.structEta`
+   constructor and therefore is not exhaustive for the current Theory
+   judgment.
+7. The current pattern contract cannot be instantiated by a live `VEnv.WF`.
+   `extra_pat` asks for a syntactic `Matches` proof for `df.lhs`, while
+   generated iota and quotient equations are registered as closed lambda
+   towers.  Their useful pattern appears only after a typed beta collapse.
+   `CertifiedExtension.covers` and `IsDefEq.appN_lamN` record the needed
+   spine-level fact, but they intentionally do not manufacture a global
+   `Params` instance.
+8. A global environment bridge must cover definitions, mutual definitions,
+   quotient rules, ordinary and block inductives, nested inductives, and the
+   registered structure-eta capability.  The current block-local assembler
+   covers one certified block plus explicitly certified extensions; it is
+   not that global bridge.
+
+Items 5 and 7 are exactly the interface decision assigned to L4L-18B.
+Nested-rule transport and the missing current-judgment coverage overlap the
+later L4L-19 work.  Pulling them into L4L-16 would not be a focused promotion
+of a completed experimental proof; it would be the extension-interface and
+consumer-bridge redesign themselves.
+
+## Route 2: live stratified derivations
+
+Decision: discard this as the L4L-16 implementation route.
+
+The live `Strong.lean` development is complete through strong translation,
+stratification, weakening, substitution, and type-shape recovery.  The
+remaining obstruction is not bookkeeping in the final sort case:
+
+1. A converted typing of a sort can have an arbitrary syntactic intermediate
+   type (for example, an application reducing to a sort).  A proof specialized
+   only to sort syntax must therefore establish uniqueness for that arbitrary
+   middle term.
+2. In the application case, the same function can be typed at two candidate
+   Pi types.  Aligning the result universes requires Pi--Pi injectivity for
+   those function types; equality of their outer `imax` levels is not enough
+   to recover the codomain levels.
+3. The live stratified uniqueness proof consequently calls
+   `forallE_inv_stratified` in its application case and `sort_inv` throughout
+   its conversion cases.  Those are the first two public admissions in
+   `Injectivity.lean`, not smaller lemmas hidden behind the current theorem.
+4. The explicit level-indexed prototype reaches the same boundary at
+   `Experimental/Stronger.lean`: `IsDefEqStrong.sort_invL` is proved, but
+   `IsDefEqStrong.uniqL'` stops in its application case with the note that it
+   needs unique typing.
+
+A bounded mutual induction does not remove this dependency.  It must prove
+sort inversion, Pi--Pi injectivity, and type uniqueness together.  That
+absorbs the central L4L-17 theorem into L4L-16 rather than completing the
+advertised sort-only route.  The current ordering, in which L4L-17 builds on
+`sort_inv`, is therefore circular for route 2.
+
+## Checked non-routes
+
+- The current Church--Rosser development is not an independent escape hatch.
+  It imports `UniqueTyping`, consumes the same sort/Pi inversion frontier,
+  and still has the two `NormalEq.parRed` admissions assigned to L4L-18A.
+- No completed proof exists on the fetched upstream `logrel` branch, the
+  current public upstream branches, or the argumentcomputer development
+  branch.  The VExpr translation branch deliberately leaves construction of
+  `Params` and constant adequacy open.
+- The completed companion semantic formalization validates the mathematical
+  route, but its calculus has fixed points and closed type formers rather
+  than lean4lean's declaration-indexed constants, generated equations, and
+  registered structure eta.  It is not a theorem that can be imported as the
+  missing environment bridge.
+
+## Required decision to resume
+
+One prerequisite ordering must change before implementation can resume:
+
+1. **Semantic route (recommended):** move the `Params`/beta-collapsed
+   extension contract and the live-environment semantic bridge ahead of the
+   L4L-16 exit, including a current `structEta` soundness case; then finish
+   constant adequacy and promote only the resulting accepted-closure proof.
+2. **Joint inversion route:** explicitly merge the L4L-16 and L4L-17 research
+   gates and implement sort inversion, Pi injectivity/discrimination, and
+   unique typing as one mutually founded development.
+
+Until one of those scopes is approved, the honest repository state is the
+unchanged public `sorry`, unchanged exact allowlist, and this blocked route
+decision.  Replacing the gap with `Params.extra_pat`, another generated
+oracle, or a theorem whose closure still contains `sorryAx` is forbidden.
+
+## Resolution (2026-08-12)
+
+Option 1 is adopted, with an independence rider: the metatheory ladder is
+reordered to land L4L-18B first, and every upstream-coordination gate is
+removed from the roadmap.  The `Params`/beta-collapsed extension interface
+is a fork-owned decision; it ships with a design note plus a
+divergence-ledger row when implemented, and upstream engagement
+consolidates in the L4L-20C PR series.  The new execution order is
+L4L-18B (extension contract and pattern interface), then the re-scoped
+L4L-16 (live-environment semantic bridge with registered structure eta,
+current-judgment VExpr-to-SExpr translation, the SExpr admissions and
+constant adequacy, and promotion of the public `sort_inv` closure out of
+`Experimental/`), then L4L-17 (remaining inversion/uniqueness statements,
+now including `registeredStructureHeadInversion`), then L4L-18A against
+the redesigned interface.  The joint L4L-16/L4L-17 merge was declined: on
+the semantic route the inversion statements arrive from one adequacy
+development, so the milestone split is no longer circular.
+
+L4L-18B subsequently removed `pat_wf` and `extra_pat` from Theory's `Params`,
+made each operational pattern step carry its exact local equality, introduced
+the explicit `Params.Extension.join` Church--Rosser obligation, and proved
+beta-collapsed coverage for generated iota rules and `quotDefEq` (design note
+`plans/l4l-18b-extension-interface-design.md`, ledger D020). The remaining
+work in this record is therefore the live semantic environment instance,
+current-judgment translation, adequacy, and public theorem promotion assigned
+to L4L-16.
+
+## Second resolution (2026-08-13): joint L4L-16/17 route adopted
+
+The L4L-16C leaf work produced a complete impossibility map
+(`plans/l4l-16-completion-plan.md`): eliminating the
+constructor-observation free closure for higher-order (lam-shaped)
+constructor fields requires typed-equality transport across a shared
+endpoint — weak heterogeneous transitivity, i.e. exactly the
+uniqueness-strength frontier — in every branch (semantic composition,
+raw composition, per-link typed sites, telescope descent), while
+first-order fields compose with machinery available today. Two exits
+were presented: stage the claim to first-order-constructor
+environments (lifting at L4L-17), or adopt this note's previously
+declined Option 2 and merge the L4L-16/L4L-17 research gates into one
+mutually founded development.
+
+John chose the joint route (2026-08-13). Consequences:
+
+- The ladder keeps the L4L-16 identifier; L4L-17's statements
+  (`forallE_inv_stratified`, `sort_forallE_inv`, `weakN_iff`,
+  `registeredStructureHeadInversion`, the reflection decision, and the
+  weak-judgment uniqueness scope retired from
+  `Experimental/UniqueTyping.lean`) become co-deliverables of the
+  joint development rather than a successor milestone.
+- The circularity objection that rejected Option 2 in the original
+  spike applied to the *live stratified* route (Route 2), where
+  uniqueness had to be assumed to prove sort inversion syntactically.
+  On the semantic route the shape-level stratification gives the
+  candidate well-founded structure: the joint induction co-proves
+  adequacy and a level-indexed limited uniqueness, each level's
+  uniqueness derived from adequacy at that level and consumed by
+  adequacy one level up (the lam-field composition). Designing that
+  mutual induction precisely — including the level-indexed statements
+  of the SExpr-side inversion lemmas, which are currently stated only
+  at the top — is the first task of the joint development.
+- Work that is route-independent proceeds unchanged: the chain
+  normalization (`CtorLink`/`CtorChain`/`toChain`), the InferType
+  principal-types bootstrap for the root sites, O3's `LE_Interp.recR`
+  argument, and the 16D instance ladder.
+- Publication holds until the joint leaf closes (John, same date).
+
+### Joint-interface checkpoint (2026-08-13)
+
+The first two implementation dependencies are now kernel-checked.
+`LR.AdequacyAt`, `LR.JointStage`, and `LR.JointBuilder` make the corrected
+offset recursion explicit, while `LogRel.LimitedUniq` states the exact
+same-term/same-shape retyping contract consumed by constructor-field
+composition. The first interface draft incorrectly claimed that arbitrary
+same-level adequacy implied this weak-judgment contract: bottom shapes erase
+typing evidence, and the target context was not required to be well formed.
+The checked replacement carries target-context validity, proves levels zero
+and one by specialized base arguments, derives level-zero alignment from the
+positive level-one observations, and only then iterates uniqueness at `n`
+into adequacy at `n + 2`. SExpr Pi/sort inversions accept adequacy at an
+explicit positive shape level.
+
+The reflection choice is conservativity modulo source level equivalence:
+well-formed `SLevel.mk` equality reflects to `VLevel` equivalence, and
+well-formed `SExpr.mk` equality reflects to `VEnv.EqUpToLevels`; literal
+syntactic injectivity is intentionally not claimed. The route-independent
+constructor normalization is also complete in the working tree:
+`CtorDefEq.toChain` produces root-anchored chains of native exact links,
+retaining lift/unlift evidence in per-link frames and using classified
+constructor-spine determinism to join transitive midpoints. The normalized
+consumer API is the three-operation `CtorChain.Algebra` (native exact leaf,
+composition, root anchoring), refined by `CtorChain.NativeAlgebra`: native
+completion precedes frame transport, and predecessor uniqueness is consumed
+only by root composition. A later raw audit strengthened exact leaves with
+equality of their constructor universe-level lists and added
+`CtorPath.foldRaw`/`CtorChain.foldRaw`/`CtorDefEq.foldRaw`. These retype every
+native edge at one common domain via `RawTypeUniq`; only the two root views
+remain explicit subject-reduction callbacks, and the normalized route is
+measured free of `sorryAx`. The generic stratified proof is now
+kernel-checked: `JointStratifiedInversion` implies contextual weak type
+uniqueness, which in turn proves both weak-head root callbacks (including beta
+and registered steps). `CtorDefEq.foldRaw_of_jointBuilder` consumes those
+callbacks and the derived uniqueness, so normalized-chain root subject
+reduction is complete conditional on a builder. The positive bootstrap is now
+also complete: non-bottom sort/Pi observations are transported across whole
+`TypeDefEqPath`s, yielding path-level inversion and stratified path uniqueness
+before any path is collapsed. Consequently level-one adequacy derives
+contextual raw uniqueness and direct `JointStratifiedInversion`; the former
+`JointBuilder.invZero` callback has been deleted. `uniqSucc` now consumes the
+exact term-indexed `LamRetype` callback (with `PiTypeAlign` only an optional
+adapter), and `JointBuilder.succ` explicitly receives lower adequacy. The
+remaining semantic obligation is the canonical-root application chain for
+the fixed iota RHS head. A native framed leaf cannot consume the root
+recursor prefix through arbitrary `unlift` refinements; synchronized endpoint
+relations are now retained as `LogRel.DefEqRect`. A spike
+resolved
+the proposed generic InferType-completeness
+shortcut negatively: weak definitional equality of an inferred function
+type with a Pi does not provide the weak-head reduction demanded by
+`InferType.app` without the very Church–Rosser/inversion result being built.
diff --git a/plans/l4l-16-stratified-observation-design.md b/plans/l4l-16-stratified-observation-design.md
new file mode 100644
index 00000000..9f19a7aa
--- /dev/null
+++ b/plans/l4l-16-stratified-observation-design.md
@@ -0,0 +1,347 @@
+# L4L-16 — the stratified-observation design question, measured and closed
+
+**Date:** 2026-08-15.  **Probe:** `plans/probes/probeT-stratpi.lean` (green:
+`lake env lean` exit 0, zero sorries, all 23 `#print axioms` checks land on
+`[propext, Quot.sound]` or `[propext, Classical.choice, Quot.sound]` — no
+`sorryAx`, and the probe imports `Lean4Lean.Experimental.ShapeLogRel` only, so
+non-circularity with respect to adequacy is structural, as in probeS).
+
+**Question.** The adequacy iota leaf `LR.iotaWitnessStep`
+(ShapeLogRelAdequacy.lean:8553, sorry at :8583; "ADQ") factors through
+`LRS.PiPathInv` (ShapeLogRel.lean:11417; "SLR"), and the recorded root cause
+is "not `SpineWF` but `LRS.ValTyPi2`/`LogRel` being `WShape`-indexed with no
+stratification index" (roadmap.md:844-848).  Three levers were on the table:
+
+* **L3** — the `RectFrame` index upgrade (probeR13-rectframe.lean);
+* **L2** — observation-local depth certificates: put depth vouchers on
+  `LRS.ValTyPi2`'s two `TypeDefEqPath`s (SLR:10282);
+* **L1** — re-index the whole relation, `LogRel Γ n` → `LogRel Γ n d`.
+
+**Verdict in one line.**  L3 closes only the frame-transport layer and
+nothing Pi-shaped; **L2 is closed on all three of its possible readings by
+machine-checked theorems — one of them refutes the banked
+`LRS.ChainAnchorAt` obstruction Prop outright (it is *false* at every
+depth, not merely fatal-if-true)** — and L1 inherits the same obstruction
+through its `trans` case (`LRS.transMiddleCertAt_false`).  The leaf is not
+closable along the stratification axis; the axis itself is now refuted, not
+just trap-equivalent.
+
+---
+
+## (i) L3 — exact coverage of the `RectFrame` upgrade
+
+What probeR13-rectframe.lean (green, no `sorryAx`, not landed) proves:
+
+* `LRS.RectFrame` — `LRS.CtorFrame` with the type shape `(a, q)` threaded
+  positionally beside the element shape — makes the whole frame-transport
+  layer of `LR.CoherentIotaLeafStep` **mechanical**: `LRS.RectFrame.rect`
+  is four one-liners (`LogRel.DefEqRect.mono_l` for `mono`,
+  `LogRel.LiftEquiv.rect` both ways for `lift`/`unlift`), plus
+  `symm_rect` and composition `RectFrame.trans`
+  (probeR13-rectframe.lean:54-77, :126-135).
+* The failure of the unpaired frame is localized **entirely in the index**:
+  `DefEqRect.mono_l` needs `m.HasType a` and `m'.HasType a` at one common
+  `a`, which a frame recording only `m ≤ m'` cannot supply, and choosing
+  `a` inside the transport is the independent re-selection the N2 decision
+  forbids (premortem l4l-16c-buildp-premortem.md:4030-4041).
+
+What L3 **does not** cover:
+
+* The residual after L3 is "produce `RectFrame`, not `CtorFrame`": the
+  shape must be threaded from the leaf that owns it through the frame's
+  *producers*, which is an index upgrade touching every producer — not an
+  additive change (premortem:4036-4041).
+* L3 never touches `LRS.PiPathInv`.  Verified two ways: (a) the probe's
+  entire content is the `DefEqRect`/`LiftEquiv` algebra — no
+  `TypeDefEqPath`, no Pi inversion, no path anywhere in the file; (b) the
+  chain-fold discipline that demands `PiPathInv`
+  (`LRS.CtorSpineTypeUniqPath.of_piPathInv`, SLR:11478;
+  `SpineWF.result_path`, SLR:11430) is a different layer of the leaf from
+  the frame transport, and the 16C′ verdict already recorded that the
+  chain-wall repair left `PiPathInv` as the *single* residual
+  (roadmap.md:708-715, SLR:11404-11416).
+
+**L3 verdict:** worth doing *if and when* the leaf's semantic content
+closes, as a mechanical cleanup of the frame layer; it closes nothing on
+the `PiPathInv` path and is not a lever on the milestone's open question.
+
+---
+
+## (ii) L2 — the crown question, split into its three readings and closed
+
+L2 proposes: store, with each observation, a voucher that the stored paths'
+vertices stratify at depth ≤ D.  The design space splits on what `D` *is*.
+Each branch is now settled by a probe theorem.  (All `probeT.*` names below
+are in `plans/probes/probeT-stratpi.lean`; `TypeDefEqPathAt` is probeS's
+depth-carrying path, restated there.)
+
+### Reading 1 — voucher as existential data (`∃ D` stored per observation)
+
+**Closed: the decoration is information-free.**
+
+* `TypeDefEqPath.restratifyData` (probeT): at any well-formed context,
+  every bare path re-decorates itself — `IsDefEq.strong` (SExpr:2996) plus
+  `IsDefEqStrong.stratify` (SExpr:2430) hand both endpoints of every edge
+  a stratified typing at one common depth, and `max`+`mono`
+  (SExpr:2397) joins them across `trans`.
+* `typeDefEqPathAt_iff_bare` (probeT): `(∃ D, TypeDefEqPathAt Γ D A B u) ↔
+  TypeDefEqPath Γ A B u` given `Ctx.WF Γ`.
+* `LRS.valTyPi2D_iff_bare` (probeT): the full certified observation
+  `LRS.ValTyPi2D` — the real `ValTyPi2` (SLR:10282) with both paths
+  vouchered under one stored `D`, reusing the live `LRS.PiDefEq` — is
+  **propositionally equivalent** to the bare observation at every
+  well-formed context.  The codomain path's context `B₁::Γ` is well-formed
+  from the domain path's own left endpoint typing, so no side condition
+  survives.
+
+Every consumer of the observation lives at a well-formed context —
+`Ctx.WF Γ₀` is the first argument of `LR.IotaWitnessStep` (ADQ:1945-1950)
+and heads every adequacy statement (ADQ:40-48).  So swapping `ValTyPi2D`
+for `ValTyPi2` inside `LRS.TyDefEq`'s Pi arm (SLR:12239) changes nothing
+about what any consumer, the leaf included, can prove: a voucher the
+consumer can manufacture on the spot from what it already holds carries no
+information.  And the manufactured `D` is `stratify`'s existential —
+nothing relates it to any rung, so the leaf's `∀ d' < d` service
+(ADQ:1965-1967) still cannot be invoked on it.
+
+### Reading 2 — voucher bounded by a uniform law
+
+**Closed: the law is FALSE, not merely fatal.**  This upgrades both banked
+obstructions.  probeS (Part 7) and SLR:16342-16371 proved the producer- and
+consumer-side stratification escapes *equivalent* to a uniform
+stratification bound and argued that its truth would make the depth
+bootstrap's strong induction vacuous.  probeT settles the question with a
+witness family:
+
+* `appHeight`/`HasTypeStratifiedS.appHeight_le` (probeT):
+  `HasTypeStratifiedS` (SExpr:2363) pays one level per `app` node along
+  every path of the syntax tree, and the induction is total over the
+  judgment, so no derivation evades the bound.
+* `idredexTower l k` — `k` nested identity β-redexes over `.sort l` — is
+  well-typed (definitionally a sort) in the **empty** context with **no**
+  environment assumptions (`idredexTower_defeq`), and admits **no**
+  stratified typing below depth `k`, at any type, flag, or context
+  (`idredexTower_min_depth`).
+* Hence, at every `d`:
+  * `LRS.uniformStratBound_false d` — the uniform bound (exactly the shape
+    of SLR:16351/16359 and probeS's `PathRestratifyAt.uniformDepthBound`)
+    is false;
+  * `LRS.chainAnchorAt_false d` — **the banked Prop `LRS.ChainAnchorAt d`
+    (SLR:16342) is itself false**; composing with probeS's
+    `PathRestratifyAt.uniformDepthBound`, `LRS.PathRestratifyAt d` is
+    false too;
+  * `LRS.voucherServiceAt_false d` — the leaf-side serviceability demand
+    ("every incoming path carries a voucher strictly below the rung") is
+    false at every rung: the tower appears as a path endpoint below every
+    rung.
+
+So any voucher discipline whose *statement* promises a fixed or
+rung-bounded depth for the paths the fold hands over is refutable.  Note
+the consistency check: SLR's `chainAnchorAt_nonvacuous` (:16371) only shows
+the Prop's *hypothesis* inhabited — which is precisely what leaves room for
+the Prop's falsity, and is why the equivalence was a real obstruction.
+
+### Reading 3 — voucher compared against the rung inside the observation
+
+**Closed: there is no place to write the comparison, and moving it into
+the index is L1 — which inherits the obstruction.**
+
+For the voucher to be *usable* at a rung-`d` leaf, the observation's
+proposition must entail `D < d` (destructuring an unconstrained `∃ D`
+yields a number the leaf cannot relate to `d`; case analysis on `D < d`
+strands the bad branch).  But the observation is defined inside
+`LogRel Γ n` (SLR:10045), whose only indices are the context, the shape
+level, and the shapes — no depth is in scope.  So the bound is either a
+constant/uniform law (Reading 2, false) or the relation gains a depth
+index — L1 by definition.
+
+### The production side (sub-question (a)), measured for completeness
+
+The real producer of Pi observations is the `forallEDF` case of the
+derivation induction (ADQ:8256-8335): the stored paths are single edges
+over the derivation's **own substituted premises** (`.single HAσ`,
+`.single (HBody.substCongr S').1`, ADQ:8280-8281, :8328-8330).
+`LE_Interp.sound` contributes only shape/level bookkeeping (the `toValTy`
+inputs, via `.out`); **it puts nothing in the paths** — the brief's
+suspected soundness wall is actually a substitution wall (see T5 below).
+probeT's `LRS.piObservation_vouchers_by_construction` measures what a
+depth-aware version of the site could voucher, given the two Pi endpoint
+certificates such an induction would hold (`HasTypeStratifiedS.forallE_inv`,
+SExpr:2577, returns components at `n - 1`):
+
+* the **domain** path vouchers at `max n n' - 1` — strictly below both
+  ambient certificates (probeS's favourable arithmetic, reproduced);
+* the **codomain left** endpoint certifies at `max n n' - 1` in the right
+  context `A :: Γ`;
+* the **codomain right** endpoint is certified by `forallE_inv` only in
+  `A' :: Γ`; landing it in `A :: Γ` needs context conversion for
+  `IsDefEqStrong`/`HasTypeStratifiedS`, and **neither lemma exists in the
+  tree** (measured by grep; the weak-judgment `IsDefEq.defeqDF_l'`
+  induction at SExpr:3562 has no strong or stratified counterpart).  The
+  fallback is `IsDefEqStrong.stratify` — an existential depth with no
+  relation to the rung, i.e. Reading 1.
+
+Two further production/closure measurements:
+
+* **`whr` never rebuilds a stored path** — verified twice: on the live
+  successor law, whose Pi arm passes `rest` through unchanged
+  (SLR:12757-12760; likewise `mono_r_2_ty` SLR:12602-12606, `mono_l`
+  SLR:12668-12672, `join_ty` SLR:12716-12724 reuse `hBB', hFF'`
+  verbatim), and on the certified observation, where the voucher *value*
+  survives verbatim (`LRS.ValTyPi2D.whr`, probeT).  The brief's suspicion
+  ("paths live on the Pi components, not the subjects") is confirmed.
+* **`trans_ty`/`symm_ty` cannot maintain voucher arithmetic natively.**
+  The live laws retype the codomain path along the domain path with
+  `TypeDefEqPath.defeqDF_l_path` (SLR:12286, :12269; SExpr:3650); the
+  vouchered step needs the two missing conversion lemmas above.  At
+  well-formed contexts the law still holds — `LRS.ValTyPi2D.trans`
+  (probeT) — but only *through the conservativity equivalence*, which
+  re-chooses the voucher; no invariant like "output ≤ max of inputs"
+  survives.  A left-endpoint-only voucher variant (production-friendly:
+  three of the four certificates above are left-or-domain) loses `symm` —
+  `TypeDefEqPathAt.symm` (probeT, mirroring probeS) consumes both endpoint
+  certificates, and `symm_ty` is a `LogRel` field (SLR:10053) that flips
+  the stored paths (SLR:12261-12275).  **Pincer:** full vouchers fail at
+  production (wrong-context codomain-right), left-only vouchers fail at
+  closure (`symm`).  Parked as T-b1; moot for the verdict since
+  consumption is refuted regardless.
+* **The σ-quantifier wall** (`substInstance_min_depth_unbounded`, probeT):
+  a fixed subject with a fixed certificate has substitution instances of
+  unbounded minimal depth, and `Adequate` (ADQ:9-13) quantifies over
+  substitutions *inside* a rung fixed before them
+  (`contextualAdequacyAt_of_adequacyAtDepth` picks the rung from
+  `H.stratify` at ADQ:8537, before any σ is chosen).  This closes the last
+  middle ground — a voucher bounded by a function of the observation's own
+  subject — because the leaf receives σ-instances.
+
+### Vacuity control (sub-question (d))
+
+Every new Prop is either refuted outright — which subsumes the
+`TShape.bot` instantiation test, there being no instance left to
+trivialize — or carries a non-degenerate witness: `TypeDefEqPathAt` at
+depth 0 in the empty context, and `LRS.ValTyPi2D` at the bot shapes
+(`TShape.bot`-side element/type shapes, the recorded cheap test) with real
+weak-head reducts, real strong edges and real depth-0 certificates
+(`typeDefEqPathAt_nonvacuous`, `LRS.valTyPi2D_nonvacuous`, probeT).  The
+observation does not collapse at bot — its path components survive — so
+the definition fails in none of the directions that killed the two
+fixed-head-terminal Props (ADQ's `FixedHeadTerminalLink` bot-kill).
+
+---
+
+## L1 — does re-indexing the relation escape, or inherit?
+
+**It inherits, in both of its natural architectures; the only unrefuted
+form is a re-founding, not a repair.**
+
+* **(L1-a) Depth-aware derivation induction** (thread the certificates
+  through `adequacy_of_iotaWitnessStep`, ADQ:7821 — currently the
+  induction is depth-blind: its signature carries no stratification, and
+  the depth bootstrap discards the certificate at ADQ:8523, for the
+  recorded reason at ADQ:8510-8515).  Refuted:
+  `LRS.transMiddleCertAt_false` (probeT) — **for every depth transformer
+  `f`, the demand "a `trans` middle certifies at `f` of the root's depth"
+  is false**: the tower sits between two endpoints certified at depth 0
+  (`HasTypeStratifiedS.sort'` is nullary, SExpr:2365 — the same asymmetry
+  that lets `LRS.SortInv` be produced at rung 0, ADQ:560-578).  This is
+  the 2026-08-15 G4 audit's "their depth is not a function of the
+  endpoints'" (roadmap.md:691-695) upgraded from an audit note to a
+  machine-checked refutation.  It applies to *any* induction over
+  `IsDefEqStrong` that must certify middles — the re-indexed relation's
+  included, since its trans law composes observations about the middle.
+* **(L1-a′) The coherent-derivation-certificate variant.**  ADQ:25-30
+  already records that "an arbitrary left-endpoint certificate does not by
+  itself bound every premise of the accompanying strong equality; a
+  coherent derivation certificate is still required" — indexing by a
+  *whole-derivation* coherent depth would cross `trans` (the middle's
+  premises are inside the certified derivation).  But the certificate
+  covers only the root derivation's nodes: the observations the induction
+  produces are about **σ-instances** (`Adequate` quantifies substitutions
+  after the rung is fixed, ADQ:9-13, :8537), and the iota leaf's own
+  obligation quantifies spine arguments with weak typings only
+  (`LR.IotaLeafDefEq`, ADQ:1840, weak spine typings at :1882-1888).
+  Neither class is covered by the root's certificate,
+  and `substInstance_min_depth_unbounded` (T5) shows it cannot be extended
+  to cover them at any fixed rung.  So this variant escapes T4 and dies at
+  T5.
+* **(L1-b) Fixed-index relation with unfiltered quantifiers**
+  (`LogRel Γ n d` where all stored data is bounded by `d` but
+  `PiDefEq`/`LamDefEq` still quantify over arbitrary weakly-typed
+  arguments, SLR:10268-10295): production must bound the stored data of
+  argument- and substitution-instances uniformly in the quantifier, which
+  is `LRS.UniformStratBound`-shaped — false
+  (`LRS.uniformStratBound_false`, `substInstance_min_depth_unbounded`).
+* **(L1-c) Depth-filtered quantifiers** (Kripke/product-order: arguments
+  quantified per-depth, observations indexed by pairs): this changes the
+  relation's meaning — adequacy's consumers apply codomain instances at
+  arbitrary well-typed arguments (`LR.adequateApp`, the fold's dependent
+  applications), so the theorem being proved changes with it.  probeS
+  Part 7 already named this "re-founding the fixpoint on a product order —
+  a milestone, not a leaf repair", and any variant that keeps the index
+  tied to typing stratification still faces (L1-a) at `trans`.  A depth
+  index decoupled from typing stratification altogether (e.g. reduction
+  step-indexing) is a different design not covered by the recorded root
+  cause (roadmap.md:844-848 names the *stratification* index) and is out
+  of scope of this measurement; nothing here refutes it, and nothing here
+  supports it.
+
+---
+
+## Staged obligations (all landed in probeT unless marked)
+
+| # | Statement (one line) | Status |
+|---|---|---|
+| T0 | Voucher-as-data is conservative: `(∃ D, TypeDefEqPathAt Γ D A B u) ↔ TypeDefEqPath Γ A B u` and `ValTyPi2D ↔ ValTyPi2` at WF contexts | probe-proved (`restratifyData`, `typeDefEqPathAt_iff_bare`, `valTyPi2D_iff_bare`) |
+| T1 | A well-typed family of unbounded minimal stratification depth exists in the empty context | probe-proved (`appHeight_le`, `idredexTower_defeq`, `idredexTower_min_depth`) |
+| T2 | The uniform stratification bound is false at every depth | probe-proved (`uniformStratBound_false`) |
+| T2a | `LRS.ChainAnchorAt d` (SLR:16342) is false at every `d`; with probeS's equivalence, so is `PathRestratifyAt d` | probe-proved (`chainAnchorAt_false`) |
+| T3 | No rung can promise strictly-below vouchers for incoming paths | probe-proved (`voucherServiceAt_false`) |
+| T4 | No depth transformer bounds a `trans` middle's certificate by the root's — L1's induction cannot cross `trans` | probe-proved (`transMiddleCertAt_false`) |
+| T5 | σ-instances of a fixed certified subject have unbounded minimal depth — no per-subject voucher bound survives `Adequate`'s quantifier | probe-proved (`substInstance_min_depth_unbounded`) |
+| T6 | Production ledger at the Pi site: domain + codomain-left vouchers at `max n n' − 1` by construction; codomain-right only via rung-unrelated `stratify` | probe-proved (`piObservation_vouchers_by_construction`); moot for the verdict |
+| T7 | `whr` preserves voucher values; `trans` holds at WF only via T0's equivalence (voucher re-chosen) | probe-proved (`ValTyPi2D.whr`, `ValTyPi2D.trans`) |
+| T-b1 | Native voucher arithmetic for `trans_ty`/`symm_ty` needs `IsDefEqStrong.defeqDF_l` + `HasTypeStratifiedS` context conversion (both measured absent) | **parked** — open sub-question, moot for the verdict (T2/T3 close consumption regardless) |
+
+---
+
+## (iii) Bottom line for the milestone decision
+
+**Leaf closable by staged proof work along the stratification axis: NO —
+machine-refuted, not merely trap-equivalent.**  Reading 1 of L2 is
+provable and adds nothing; Readings 2-3 and both natural forms of L1 are
+false; the banked obstruction Props (`ChainAnchorAt`,
+`PathRestratifyAt`-shaped) are now known false at every depth, which is
+the strongest possible form of "do not open the stratification work"
+(roadmap.md:830-831).  The root-cause note (roadmap.md:844-848) should be
+read as an *autopsy*, not a work item: adding the missing stratification
+index is not a repair that was left undone — it is a repair that cannot
+exist in the fixpoint as founded.
+
+**What remains standing** is the adequacy route's semantic content itself
+(`PiPathInv.of_adequacy` — roadmap.md:844-846, "the only one standing"),
+now with the depth axis closed around it.  The one direction the measured
+record marks attackable and this work does not touch: the residual's
+subjects at the leaf are **registered declarations** — "the first residual
+a generation-side argument can attack" (roadmap.md:708-711;
+SLR:11380-11388, `constTypeUniqPath`'s docstring: a registered declaration
+has one type).  `LRS.constSpineTypeUniqPath` (SLR:11458) currently spends
+general `PiPathInv` once per spine layer; whether the leaf's actual demand
+can be narrowed to Pi inversion **with one endpoint pinned to a registered
+telescope** (`SExpr.mkInst ls ci.type` and its instantiations) — a class
+the environment generates and finite per-declaration induction might
+invert without general Π-injectivity — is unmeasured.  The banked
+sort-typed narrowing provably did not dodge the hard case
+(roadmap.md:799-803), but that β-case obstruction lives in the *ladder*
+loop at arbitrary abstraction domains; the *leaf's* chain-fold demands are
+constructor/registered-headed, so the registered-endpoint narrowing is a
+genuinely different, unrefuted question.
+
+**Single next action:** probe the registered-endpoint narrowing — restate
+the leaf's two `PiPathInv` call sites (`SpineWF.result_path`'s layers on
+constructor spines, SLR:11430; the `rootRed` residual's type paths,
+roadmap.md:712-715) as Pi inversion at registered-telescope endpoints,
+measure whether both sites fall inside the class, and attempt the
+per-declaration telescope induction for it.  If that class also escapes,
+the leaf's remaining cost is the full semantic content
+(sort/Pi-disjointness + standardization) with no structural shortcut left
+on the map.
diff --git a/plans/l4l-16-typedview-design.md b/plans/l4l-16-typedview-design.md
new file mode 100644
index 00000000..6aa68e64
--- /dev/null
+++ b/plans/l4l-16-typedview-design.md
@@ -0,0 +1,316 @@
+# L4L-16 — the typed constructor view, measured and closed
+
+**Date:** 2026-08-15.  **Probe:** `plans/probes/probeV-typedview.lean` (green:
+`lake env lean` exit 0, zero sorries, all 19 `#print axioms` checks land on
+`[propext, Quot.sound]` or `[propext, Classical.choice, Quot.sound]` — no
+`sorryAx`; first-compile green).  The probe imports
+`Lean4Lean.Experimental.ShapeLogRel` **only**, so non-circularity with respect
+to adequacy is structural, as in probeS/probeT/probeU: `LR.AdequacyAt`,
+`LR.ContextualAdequacyAt(Depth)` and every `*.of_adequacy*` are not in the
+import closure at all.  No banned input is touched (no `ParRedSDefeq`/
+`CRComplete`/`PiStandard`/`PiEdgeInv`/`SubjectRedS`/`PiEdgeObs`, no
+`WHRedS.defeq`, no `TypeDefEqPath.collapse`/`RawTypeUniq`, no Theory
+`ParRed.defeq`/`StRed.triangle`; the axiom closures certify this).
+
+**Question.**  probeU (l4l-16-registered-pi-design.md) reduced the 16C′
+leaf's general-`PiPathInv` uses on the live path to exactly two root
+callbacks — `rootRed` (ADQ:1114): `LRS.CtorView Γ₀ M X → IsDefEq Γ₀ M M A →
+IsDefEq Γ₀ M X A`, weak-head subject reduction of an arbitrary root to its
+classified constructor spine — and recorded one next action: upgrade
+`LRS.CtorView` (SLR:11009) to a **typed view** carrying `IsDefEq Γ M X A`,
+the exact analogue of the repair that dissolved the chain interior
+(`CtorRetype`/`CtorSpineTypeUniqPath`: *retained*, not proved —
+roadmap.md:699-712).  Measure whether every producer on the leaf path can
+supply the retained typing, and whether the two callbacks then dissolve into
+(a) the stored `⤳*` + (b) the retained typing + (c) registered-strength
+inversion only.
+
+---
+
+## Verdict in one line
+
+**(ii) — the map is complete.**  The dissolution is a real theorem: with
+typed views at the fold's package type, both root callbacks vanish into
+projections and the leaf's entire chain residual costs
+`LRS.CtorSpineTypeUniqPath` — i.e. `LRS.PiPathInvReg` — only.  But the typed
+view is **not producible through the relation**: of its four producers on the
+leaf path, the native exact nodes pass, while the three closure-law producers
+fail for three independent, machine-checked reasons — the forward weak-head
+law is *equivalent to* the subject reduction being dissolved, the backward
+law is *refuted outright* (a K-redex typing an ill-typed discarded argument,
+against the landed `PiNotFunTyped.of_soundness`), and the `conv` law's
+premise at the ctor arm is shape-only, so a conv-closed typed view *provably
+collapses all registered inductive head types into one path class*.  The one
+retention that survives every closure law (the anchored view) leaves the
+callback's demand byte-for-byte where it was.  So `rootRed` cannot be
+retained away: it **is** general weak-head subject reduction restricted to
+constructor targets, which the banked record
+(`LRS.piPathInv_iff_parRedSDefeq`, SLR:16210; probeU U5/U2;
+roadmap.md:781-831) places at exactly the leaf's own strength.  No structural
+axis remains unmeasured.
+
+---
+
+## (i) The dissolution theorem — the conjecture of the brief, made exact
+
+`LRS.CtorViewT Γ M X A` (probeV Part 1) is `LRS.CtorView` plus one field:
+`IsDefEq Γ M X A`, the subject typed against its spine at the observation's
+package type.  `LRS.CtorChainT` is `LRS.CtorChain` (SLR:11689) with both
+endpoint views typed at the fold's own `D`.  Then, machine-checked:
+
+* `LRS.CtorChainT.foldRaw_of_anchorDiscipline` — the raw fold with **no root
+  callbacks at all**.  Where `LRS.CtorChain.foldRaw_of_anchorDiscipline`
+  (SLR:11759) takes `left`/`right` subject-reduction callbacks, the typed
+  fold takes nothing: `alg.anchor` receives `hleft.defeq`/`hright.defeq` by
+  projection, and the path seed is `hleft.defeq.hasType.2`.
+* `LRS.CtorChainT.rawDefEqAt_of_anchorDiscipline` — the raw-equality half,
+  likewise callback-free.
+* `LRS.CtorChainT.foldRaw_of_ctorSpineTypeUniqPath` — the same from the
+  environment-level constructor discipline alone, which probeU proved from
+  `LRS.PiPathInvReg` (U4: `LRS.CtorSpineTypeUniqPath.of_piPathInvReg`).
+
+So the brief's decomposition "(a) stored `⤳*` + (b) retained typing + (c)
+`PiPathInvReg`-strength inversion only" is a **theorem**, conditional on
+production: if typed views reach the fold, the leaf's entire residual —
+interior *and* roots — is the registered narrowing.  Everything below is the
+measurement that they cannot reach it.
+
+What the two callbacks actually need (the brief's determination question):
+`foldRaw_of_majorChainAnchorStep` (ADQ:1191-1202) invokes `rootRed` with the
+caller's `hM : IsDefEq Γ₀ M M D` and needs `IsDefEq Γ₀ M X D` **at the
+fold's `D`** — at the leaf, `D` is `hlastPair.domain` and `hM`/`hN` are
+`hlastPair.major.hasType.{1,2}` (SExpr:1433, `LastPair.major`).  So the form
+the callbacks need is the root-typed view **at `D` itself** — not a typing
+at some other package type (which would re-open raw type uniqueness at `M`
+to reconcile), and not an anchored typing (see (iv)).
+
+---
+
+## (ii) The producer inventory — one passes, three fail
+
+The complete set of `LRS.CtorView` introduction sites in the tree (grep):
+`toChain`'s `exact` case (SLR:11985-11986), `CtorView.whr` (SLR:11021),
+`CtorView.unwhr` (SLR:11028); plus the relation-level laws that feed them —
+`LRS.CtorDefEq`'s `whr`/`unwhr` constructors (SLR:10776-10779), demanded by
+the `LogRel` interface's **untyped iff** `whr` law (SLR:10064) through
+`LRS.IndDefEq.whr` (SLR:12189-12193), and the `conv` law (SLR:10057) at the
+ctor arm (`LRS.DefEq`, SLR:12448).  Measured one by one:
+
+**(P1) Exact nodes — PASS** (`LRS.CtorExact.toChainT`, probeV Part 2).
+Every native exact leaf yields a typed chain of length one at one common
+package type: `LRS.CtorExact.rawDefEq` (SLR:10998) *is* the retained typing,
+because a `CtorExact`'s subjects are the spines themselves (SLR:10966-10968).
+Both live `LRS.CtorDefEq.exact` production sites — the nullary-constructor
+cases of `LR.SelfAdequateConstStep.of_steps` (ADQ:7736) and of the
+derivation induction `LR.adequacy_of_iotaWitnessStep` (ADQ:8034) — store
+`.rfl` reductions with the head typing `.const hreg hlen` in scope, so the
+origin producer supplies the typing with no new obligation.
+
+**(P2) The forward law (`toChain`'s `whr` case) — IS THE RESIDUAL**
+(`LRS.ctorViewT_whrClosure_iff`, probeV Part 3).  The transport
+`WHRedS Γ M M' → CtorViewT Γ M X A → CtorViewT Γ M' X A` is **equivalent**
+to `LRS.CtorTargetSubjectRed`: edge-splitting subject reduction along
+constructor chains (`M ≡ X : A` and `M ⤳* M'` give `M' ≡ X : A`).  Its
+single-β-step content (`CtorTargetSubjectRed.beta_step`) is verbatim the
+per-step obligation `WHRed.defeq_of_piPathInv` (SLR:11507) discharges from
+the general leaf at its `beta` case (SLR:11523-11536), where `piInv` is
+charged on the abstraction's own declared Pi; and the typed view is
+reachable through β at an abstraction domain the view leaves completely free
+(`LRS.ctorViewT_beta_view` — the typed sharpening of probeU's
+`rootRed_meets_beta`/U5, whose Pi endpoints U2 put outside every measured
+narrowing).  So "retain and transport forward" is not a repair; it is the
+residual restated.
+
+**(P3) The backward law (`toChain`'s `unwhr` case) — REFUTED**
+(`LRS.ctorViewT_unwhrClosure_false`, probeV Part 4).  `LogRel.whr` is an
+iff; its right-to-left direction gives the free `unwhr` constructor an
+arbitrary new root with a bare `WHRedS` and *no typing in any scope* — this
+is the structure field itself, not an accident of a call site.  The typed
+transport it imposes is **false**, conditional only on the environment
+classifying and typing one constructor (the established non-vacuity
+discipline): the K-redex
+`(fun _ : T₀ => c) ((Prop → Prop) Prop)` β-reduces to `c`, so the law would
+type it at `T₀`; `IsDefEq.strong` (SExpr:2996) plus two applications of the
+banked structural inversion `IsDefEqStrong.app_inv'` (SExpr:3688) then type
+the discarded argument's function part — `Prop → Prop` — **at a Pi**, and
+`LRS.PiNotFunTyped.of_soundness` (SLR:15058, landed from `LE_Interp.sound`
+outside the fixpoint) refutes it.  No closedness induction, no new
+inversion, no adequacy rung.
+
+**(P4) The `conv` law — COLLAPSING** (probeV Part 5).  The ctor arm lives at
+the `.indTy` type shape, and the semantic type equality there is
+**shape-only**: `LRS.TyDefEq.indTy_m` (SLR:12476, restated as
+`LRS.convPremise_at_indTy`) says the conv premise is two `IndTyHead`
+classifications and *nothing else* — no raw equality, no path, no shared
+subject.  A conv-closed typed view (`LRS.TypedViewConvClosure`) therefore
+transports a spine's typing between package types with no raw connection,
+and `LRS.typedViewConvClosure_collapses` shows that together with the
+interior discipline the chain repair already retains
+(`LRS.CtorSpineTypeUniqPath`) it path-connects the spine's telescope result
+type with **every** registered inductive head type simultaneously — with two
+registered inductives, `TypeDefEqPath Γ NatTy BoolTy`.  That is the
+registered-uniqueness discipline (`LRS.constTypeUniqPath`, SLR:11389 — one
+type per registered declaration) in reverse: the obligation is not merely
+unsupplied by its premises, it is absurdity-grade in the intended model, so
+no producer for it can be built.  (This is a conditional refutation — an
+outright `False` would need a separating model, which the abstract `Params`
+does not provide; the collapse is the strongest available form and is
+sufficient for the verdict.)
+
+**The law/site distinction, recorded for completeness.**  At every *live*
+application of the closure laws in the adequacy producer, a typed edge is in
+scope — enumerated: ADQ:4090 (iota fire; `hterm` + `action.sound`),
+ADQ:7154/7165/7170 and 8243/8251/8254 (β-expansions in the lambda evaluator;
+rule premises + argument typings, edge via `IsDefEq.beta`), ADQ:7790
+(constant unfold; `Params.Semantic.defn_whRed`'s retained `IsDefEqStrong`
+edge, ADQ:7266-7275), ADQ:8481/8488 (defn case; the rule's own `Hdef`
+substituted), and the two forward uses ADQ:8439/8498 (β/extra reducts; edges
+constructible from premises / `action.sound`).  The typings exist at every
+entry and **die at the arm boundary**, because the arm must satisfy the
+untyped iff.  That is the precise sense in which the `LogRel` interface —
+not any single proof — is what erases root typings; re-typing them
+downstream is `rootRed`, and re-founding the interface on a typed `whr` law
+is the L1-class relation change probeT already closed ("re-founding, not
+repair"), and it would still fail (P4) at `conv`, whose indTy premise is
+shape-only by the definition of the relation's type arm (SLR:12240).
+
+**The leaf's own scope (the brief's `htermI`/`hAIType`/`hspineXI/YI`
+check).**  At the sorry site (ADQ:8583) those hypotheses type the *recursor*
+spines at `AI` and supply `AI`'s sort; the callback inputs at
+`D = hlastPair.domain` come from `hlastPair.major.hasType` — sufficient to
+*invoke* the callbacks, and sufficient to *build* the typed views at the
+roots only given `IsDefEq Γ₀ majorX X D` — which is the callback's own
+conclusion.  Manufacturing the typed view at the fold entry from the
+caller's inputs is `rootRed` verbatim; the circularity is structural, not an
+artifact of missing lemmas.
+
+---
+
+## (iii) The anchored form — the survivor, and why it is worthless
+
+`LRS.CtorViewA` (probeV Part 6) decouples the typing from the root: some
+vertex `M₀` with `WHRedS Γ M₀ X` carries `IsDefEq Γ M₀ X A`, while the
+subject's own prefix stays bare.  Machine-checked: it is closed under both
+transport directions (`CtorViewA.whr` via `WHRedS.determ_l` +
+`WHNF.ctorSpine`; `CtorViewA.unwhr` by prefix absorption) and produced at
+the origin with the degenerate anchor `M₀ := X`
+(`CtorViewA.of_spineTyping`) — so it *is* producible everywhere, including
+through the untyped iff.  And it dissolves nothing: the callback's residual
+demand (`LRS.CtorViewA.Extraction` — close the untyped prefix at the
+caller's `D`) is implied by `rootRed` unchanged
+(`Extraction.of_rootRed`), and its demand family still reaches the β site
+with a free abstraction domain (`LRS.ctorViewA_beta_premises`: both the
+anchored view and the caller-side typing are inhabited at a K-redex whose
+domain nothing constrains — probeU's U5 obstruction, untouched by the
+anchor).  Anchoring at the pre-reduction root (the brief's suggested
+variant) is the special case `M₀ :=` the whr-case's old subject, and the
+extraction gap it leaves is the same untyped prefix.
+
+Parked as **V-b1** (moot for the verdict): a "typed shadow" certificate
+carried *beside* the relation rather than inside it, produced at the live
+sites where typings exist.  Two named walls bound it: it must follow the
+relation through `conv` (P4's shape-only premise applies to any carrier
+indexed by the package type), and a shadow indexed by the spine's own
+telescope type instead re-opens the `A`-vs-`D` reconciliation at the fold,
+which is raw type uniqueness at the root.  Threading it through the
+relation's function-space quantifiers is the carrier change probeT's L1
+analysis classified as a re-founding.
+
+---
+
+## (iv) The crown sub-question, demoted and measured
+
+Under verdict (ii) the leaf's residual is *not* reduced to
+`LRS.PiPathInvReg`, so single-edge Pi inversion at a registered endpoint is
+no longer "the one hard lemma" — the roots keep their general demand
+regardless.  The probe still measures its shape, because probeU left it as
+the only unexamined narrowing of U8:
+
+* **U8 recap:** the registered class is not closed under one *path* edge,
+  and every registered Pi has unregistered path interiors — path-structural
+  induction dies at `TypeDefEqPath.trans`.
+* **New (probeV Part 7):** the same wall exists one level down, inside the
+  single edge itself.  `IsDefEq.trans` (SExpr:1263) is a constructor of the
+  edge relation, its middle is existential, and
+  `regEdge_trans_middle_escapes` shows every edge between two Pis — both
+  endpoints registered included — factors through a middle
+  (`(fun _ : Sort s => #0) (∀A,B)`) that is outside the class at every
+  arity **and not syntactically a Pi**, with no environment assumptions.  A
+  derivation induction walking the one edge from its registered end hands
+  its inductive hypothesis, at the first `trans` constructor, an edge with
+  neither a registered nor a Pi left endpoint.
+
+So single-edge inversion at a registered endpoint is **not a different
+question**: it is U8's question transposed from the path's `trans` to the
+derivation's `trans`, and it falls to the same middle-escape.  What survives
+a `trans`-refactoring (walking only the non-`trans` constructors) is exactly
+the semantic content — `beta`/`eta`/`proofIrrel`/`extra` — i.e. the
+soundness-shape/standardization route the 18A′ map already prices, and
+which `LRS.piPathInv_iff_parRedSDefeq` makes interderivable with the leaf.
+Crown outcome: **mooted by the verdict, and independently closed as a
+structural attack; the residual attack surface on the edge is semantic
+only.**
+
+---
+
+## Staged obligations (all landed in probeV unless marked)
+
+| # | Statement (one line) | Status |
+|---|---|---|
+| V0 | Typed view/chain defined; projections to the live view and typing | probe-proved (`CtorViewT.toView`, `.defeq`) |
+| V1 | **Dissolution:** a typed chain folds with NO root callbacks, from the anchor discipline alone | probe-proved (`CtorChainT.foldRaw_of_anchorDiscipline`, `.rawDefEqAt_of_anchorDiscipline`) |
+| V1′ | …and hence from `LRS.CtorSpineTypeUniqPath` alone — with probeU U4, from `LRS.PiPathInvReg` | probe-proved (`CtorChainT.foldRaw_of_ctorSpineTypeUniqPath`) + banked U4 |
+| V2 | **Producer (exact): PASS** — every native exact leaf yields a typed chain at one common package type | probe-proved (`CtorExact.toChainT`) |
+| V3 | **Producer (whr): IS the residual** — forward transport ↔ edge-splitting subject reduction; β content = the leaf's `piInv` site; typed views reachable through β with the domain free | probe-proved (`ctorViewT_whrClosure_iff`, `CtorTargetSubjectRed.beta_step`, `ctorViewT_beta_view`) |
+| V4 | **Producer (unwhr): FALSE** — the backward transport the untyped iff imposes is refuted (K-redex + `app_inv'`×2 + landed `PiNotFunTyped.of_soundness`) | probe-proved (`ctorViewT_unwhrClosure_false`) |
+| V5 | **Producer (conv): COLLAPSING** — the indTy conv premise is two `IndTyHead`s only; a conv-closed typed view + the retained interior discipline path-connects all registered inductive head types | probe-proved (`convPremise_at_indTy`, `typedViewConvClosure_collapses`) |
+| V6 | The anchored view survives all closure laws and production | probe-proved (`CtorViewA.whr`, `.unwhr`, `.of_spineTyping`) |
+| V7 | …and buys nothing: its extraction is implied by `rootRed` and still meets the free-domain β site | probe-proved (`Extraction.of_rootRed`, `ctorViewA_beta_premises`) |
+| V8 | **Crown (demoted):** single-edge inversion at a registered endpoint inherits U8 at the derivation level — `IsDefEq.trans` middles are unregistered non-Pis between registered endpoints | probe-proved (`regEdge_trans_middle_escapes`, `RegTeleV.not_app_lam`) |
+| V-b1 | Typed shadow certificate beside the relation (conv-following + `A`/`D` reconciliation walls; L1-class carrier change) | **parked** — moot for the verdict |
+
+---
+
+## (v) Closure statement for the milestone decision
+
+With probeT (stratification: machine-refuted), probeU (registration: closes
+the chain interior, not the roots; the narrowed Prop no easier), and probeV
+(retention: dissolution real, production impossible), **every structural
+axis on the 16C′ leaf is measured and closed**.  The completed map:
+
+* `rootRed` = weak-head subject reduction to a classified constructor spine.
+  Retention cannot remove it (V3/V4/V5); anchoring cannot weaken it (V7);
+  registration cannot narrow its β case (probeU U5 + U2); sort-typing
+  cannot (banked witness, roadmap.md:799-803); depth vouchers cannot
+  (probeT T2/T3/T5).
+* Its β content — reconciling an application's domain with the
+  abstraction's own annotation — is the exact site where every route into
+  the leaf (`WHRed.defeq_of_piPathInv` beta, `ParRed.defeq` beta,
+  `StRed.triangle`) charges Pi injectivity, and
+  `LRS.piPathInv_iff_parRedSDefeq` (SLR:16210) makes any subject-reduction-
+  grade Prop interderivable with the leaf itself.  `rootRed` is therefore
+  not an input *to* the leaf; it is the leaf.
+* The interior (chain links, spine layers) costs `LRS.PiPathInvReg` only
+  (probeU U4/U4′), and with typed views it would be the *whole* cost (V1′)
+  — but the views die at the relation's interface, whose untyped `whr` iff
+  and shape-only indTy `conv` are load-bearing (V4, V5).
+
+The milestone decision this closes: 16C′ cannot be finished by any further
+structural probe.  The remaining options are exactly two, and both are now
+priced: **(A)** re-scope 16C′ with `LRS.PiPathInv` as its single named open
+input (the tree already threads the entire consumer surface — chain fold,
+anchor step, CR ladder, adequacy leaf — through that one Prop), or **(B)**
+fund the semantic content itself (sort/Pi disjointness is landed; what
+remains is standardization/Church–Rosser-grade normalization for the typing
+judgment, which the interderivability results price at the leaf's own
+strength, outside the fixpoint).  There is no option (C).
+
+**Single next action:** no further probe on this leaf.  Update roadmap.md's
+16C′ section with verdict (ii) and the completed three-axis map
+(probeT/probeU/probeV), and take the milestone decision between (A)
+parameterizing on `LRS.PiPathInv` and (B) scheduling the semantic
+normalization work — recording, either way, that `CtorChainT` (probeV Part
+1) is the interface the leaf should consume the moment the leaf's Prop
+lands, since it makes the entire residual `LRS.PiPathInvReg`-shaped.  Do
+not re-open: stratification (probeT), sort narrowing (banked), registered
+path/derivation induction (U8 + V8), or view retention (V4/V5).
diff --git a/plans/l4l-16-weakn-design.md b/plans/l4l-16-weakn-design.md
new file mode 100644
index 00000000..1ef46034
--- /dev/null
+++ b/plans/l4l-16-weakn-design.md
@@ -0,0 +1,283 @@
+# L4L-16E design pass: `IsDefEqU.weakN_iff`, forward direction
+
+2026-08-15. Companion probe: `plans/probes/probeE-weakn.lean` (type-checked
+statements for every staged obligation; two clean proofs; one tainted
+assembly certificate). Target:
+`Lean4Lean/Theory/Typing/UniqueTyping.lean:171-174` — the sole sorry gating
+the entire strengthening suite (`weakN_iff'`, `OnCtx.weakN_inv`,
+`IsDefEq/HasType/IsType.weakN_iff`, `skips`, `weak'_iff`, the SpineWF
+inversions, ~20 ChurchRosser sites, projection/TrProj consumers).
+Allowlisted at `Audit/SorryFrontier.lean:173`.
+
+## 1. Decision
+
+**Route: de-circularized stratified standardization on the Theory side
+("SST"), executed as an L4L-18A′-coupled slice — NOT as a 16E leaf.**
+The forward direction is real mathematics: it is the strengthening
+corollary of typed standardization (Church–Rosser + normal-comparison
+strengthening), and every elementary route is provably blocked (§3, §4).
+The repo already contains ~2,600 lines of exactly the needed machinery
+(`ChurchRosser.lean`, `HeadReduction.lean`) — but built *downstream* of
+this sorry, consuming it in the core. The work is therefore a
+dependency-inversion refactor plus two genuinely new proof cores, not a
+from-scratch development. Verdict: **research-grade** (3–6 focused weeks
+after its inputs land), and it cannot close within 16E as scheduled.
+Recommendation for sequencing in §7.
+
+The probe machine-checks the decisive positive fact: given the staged
+lemmas (S1, S-PR, S-NE below), the forward direction assembles in ~15
+lines (`IsDefEqU.weakN_inv_staged`). Everything reduces to making those
+stages weakN_iff-free.
+
+## 2. Corrections and additions to the recorded route analysis
+
+Verified against source; differences from the 2026-08-15 recon:
+
+1. **`Theory/Typing/HeadReduction.lean` was missing from the map** and is
+   the single most important file for this problem: Theory-side `WHRed`
+   with proved `weakU_inv` (:94), `WHRedS.weakU_inv` (:292), whnf
+   determinism, standardization `StRed` + `ParRedS.standard` (:489),
+   head-normalization of defeq at observation heads
+   (`IsDefEq.reduce_sort` :493, `reduce_forallE` :512), and a
+   syntax-directed `InferType` with `determ`, `weakU_inv` (:586) and
+   completeness `InferType.exists` (:658, `[Params.Extension]`). It has
+   **no sorries** — but is tainted: its four `weak'_iff` uses
+   (:110, :112, :599, :603) ride on the target sorry.
+2. The recon's "`WHRed.weakU_inv` `.extra` is sorried and a prerequisite"
+   refers to the **SExpr mirror** (SExpr.lean:3810). The Theory-side
+   `.extra` case is *proved* — by consuming `IsDefEqU.weak'_iff`
+   (HeadReduction.lean:110-112), i.e. it is tainted, not missing. Same
+   pattern at `ParRed.weakN_inv` (ChurchRosser.lean:1173/1175): the
+   structural cases are strengthening-free; only the pattern-action
+   certificates need the theorem.
+3. The Theory-CR circularity is deeper than "ChurchRosser consumes
+   weakN_iff": it is definitional and interface-level. `NormalEq` and
+   `StructEq` embed full typing/defeq judgments in their constructors
+   (ChurchRosser.lean:137-218), so *their* strengthening is judgment
+   strengthening; the CR core consumes it inside `NormalEq.trans`'s
+   eta-eta case (:896), `hasType_app_bvar0` (:1537), `NormalEq.parRed`
+   (:1634, :1699), and the DFC family (:609-812). Moreover the `Params`
+   class itself carries `forallE_weakN_inv` and `structEta_weakN_inv` as
+   *assumed oracle fields* (ChurchRosser.lean:32-76) which the roadmap
+   plans to discharge FROM the 16E co-deliverables at L4L-18A instance
+   time — i.e. the plan's dependency direction is weakN_iff → CR, and
+   using CR for weakN_iff inverts a planned edge (cf. the 16C′ precedent
+   commit "first joint-induction design pass inverts the dependency
+   order").
+4. The brief's candidate repair for the strong route — use
+   `HasType.skips`/`weakN_inv` on the trans midpoint's TYPE — is
+   circular: `IsDefEq.skips`/`HasType.skips` are corollaries of
+   `weakN_iff` itself (UniqueTyping.lean:180-187, 225-228). And even
+   granted, it does not help (§3).
+5. `IsDefEq.uniq` and everything before UniqueTyping:171 is
+   weakN_iff-free, but consumes the sorried Injectivity endpoints
+   (`forallE_inv_stratified` at :43; Injectivity.lean:12/21/34 are all
+   sorried 16C′ co-deliverables). "The suite is proved modulo this one
+   sorry" is accurate only modulo those three as well; SST likewise
+   treats them as available inputs.
+6. **No VExpr-side gaps**: `liftN_inj`, `skips_iff_exists`,
+   `inst_lift/inst_liftN`, `liftN_inst_hi`, `lift'_inj`,
+   `Pattern.RHS.apply_liftN`, `Pattern.matches_lift'` all exist. No O0
+   stage is needed.
+7. Truth check (statement-repair scan à la
+   `registeredStructureHeadInversion`): WF environments acquire defeqs
+   only through `VDefVal.toDefEq` (lhs a bare constant; Env.lean:19-57)
+   plus registered ι/structEta — no arbitrary defeq axioms — so the
+   CR-strength inputs are plausible for every genuinely WF env and no
+   falsity landmine was found. The forward direction is believed true as
+   stated.
+8. Semantic-route wall, sharpened: the shape relation is *observationally
+   poor by construction* — `LogRel.bot` and `LR0.DefEq` relate ALL terms
+   at bot shape (ShapeLogRel.lean:9921, 10046-10056) — so relatedness can
+   never imply `IsDefEqU` for an arbitrary pair. `LE_Interp.weak'_iff`
+   (:5893) and `LogRel.LiftEquiv` (:10751) descend the *relation*
+   perfectly; the loss is at reflection, which does not exist and cannot
+   exist for this relation design. Adequacy extracts judgments only at
+   sort/Pi/ctor observation heads (ShapeLogRelAdequacy.lean).
+
+## 3. The wall, precisely
+
+**Obstruction: trans-midpoint re-lift gluing.** Machine-checked witness
+(`probe_wall_witness`, clean): for any `Γ ⊢ e : B` and any inserted type
+`A₀`,
+
+```
+A₀::Γ  ⊢  (fun x : A₀↑ => e↑↑) (bvar 0)  ≡  e↑  :  B↑
+```
+
+The midpoint mentions the inserted variable essentially (it is applied via
+the `bvar` rule inside `beta`), is not a lift of anything, yet is defeq to
+a lift. Consequences, route by route:
+
+- *Induction on the weak derivation*: at `trans`, neither subderivation
+  has two lift endpoints. Strengthening the statement to "one lift
+  endpoint ⇒ other endpoint defeq to a lift + strengthened equation"
+  makes each IH produce a *different* strengthening of the shared
+  midpoint (`em`, `em'` with `Γ' ⊢ em↑ ≡ m ≡ em'↑`); gluing them into
+  `Γ ⊢ em ≡ em'` is the target theorem applied to `em↑ ≡ em'↑` — a
+  derivation that is NOT a subderivation. No structural or size measure
+  decreases (`meas` is lift-invariant). Two formalization attempts of
+  this shape are pointless; the failure is structural.
+- *Induction on `IsDefEqStrong`*: identical. Strong `trans` is
+  homogeneous (midpoint typed at the same `A` in the same `Γ'`,
+  Strong.lean:21), but typedness does not remove the `bvar 0` occurrence
+  from the midpoint TERM: the witness's typed variant has liftable type
+  `B↑` and an unliftable term. Substituting the midpoint away needs
+  `IsDefEqStrong.instN`'s typed witness `h₀` (Strong.lean:410) — i.e.
+  inhabitance of the inserted types, which fails in general (`False`).
+  `HasType.skips` on the type is circular per §2.4.
+- *Underlying reason there is no elementary proof*: strengthening is
+  equivalent to finding a section of the weakening context morphism,
+  which exists only when the inserted types are inhabited; every known
+  non-elementary proof replaces the section by normalization-strength
+  machinery (standardization or a neutral-terms/Kripke model). This
+  matches upstream: Injectivity.lean's header ("structural theorems
+  which we can't prove :(") and this sorry are the same class of fact.
+
+## 4. Route verdicts
+
+| Route | Verdict | Killing obstruction |
+|---|---|---|
+| A. Induction on weak `IsDefEq` | dead | trans-midpoint re-lift gluing (§3, witness proved) |
+| B. Induction on `IsDefEqStrong` (entry `IsDefEq.strong`, exit `.defeq`) | dead | same wall; typed midpoint still unliftable; `instN` needs inhabitants; `HasType.skips` circular |
+| C. Semantic descent (`LE_Interp.weak'_iff` → unlift → reflect) | dead | observation poverty: bot shape relates everything (ShapeLogRel.lean:10046); no reflection for arbitrary pairs, by relation design |
+| D. Theory-CR as currently structured | dead (circular) | CR core consumes the suite (ChurchRosser.lean:896, 1537, 1634, 1699, 1173-1175, 609-812); `Params` oracle fields owed BY weakN_iff; module order (`ChurchRosser` imports `UniqueTyping`) |
+| E. Witness substitution | partial only | sound and cheap when insertions are inhabited (`IsDefEqU.strengthen_of_witness`, proved); not the theorem |
+| F. **SST — de-circularized stratified standardization** | **chosen** | none structural; cost is research-grade re-founding (§5, §6) |
+| G. Oracle field (`defeq_weakN_inv` in `Params`) | rejected | violates the 16E exit criterion "no environment oracle on any path" (roadmap); relocates the sorry without closing it |
+| H. SExpr-side counterpart first (`SExpr.IsDefEq.weakU_inv`) | rejected | same wall, and SExpr has NO CR core (the `CRDefEq` mirror was deleted at 16B′ precisely because it required one); would duplicate 2,600 Theory lines. Keep `SExprCounterpartDrafts.lean` statement-only |
+
+## 5. The chosen route in one page
+
+Forward proof dataflow (machine-checked as `IsDefEqU.weakN_inv_staged`,
+probe Part 3):
+
+```
+IsDefEqU Γ' e1↑ e2↑
+  → church_rosser:            Γ' ⊢ e1↑ ≫* x,  Γ' ⊢ e2↑ ≫* y,  Γ' ⊢ x ≡ₚ y
+  → S-PR (ParRedS.weakN_inv): x = x₀↑, y = y₀↑,  Γ ⊢ e1 ≫* x₀,  Γ ⊢ e2 ≫* y₀
+  → S-NE (NormalEq.weakN_inv): Γ ⊢ x₀ ≡ₚ y₀
+  → S1 (HasType.weakN_inv_ex): Γ-typings of e1, e2
+  → glue by soundness + IsDefEqU.trans.
+```
+
+Today every arrow except the last exists but rides on the target sorry.
+SST makes the tower weakN_iff-free by proving it as ONE mutual
+development, well-founded on **stratified typing depth**
+(`HasTypeStratified`, Strong.lean:926 — the exact pattern of
+`IsDefEq.uniq` and of the 16C′ `JointStratifiedInversion` bootstrap):
+
+- Strengthening at depth `d` may consume the re-founded CR core at depth
+  `d`, which may consume strengthening only at depth `< d` (types live
+  one stratification level below their terms: `proofIrrel`'s proposition,
+  binder domains, `defeqDF` sort equations).
+- The four `Params` oracle fields (`forallE_weakN_inv`,
+  `structEta_weakN_inv`, and the two disjointness fields) become
+  per-depth *lemmas* of the development instead of instance obligations —
+  simplifying the planned L4L-18A live-instance work.
+- Existing proof scripts survive nearly verbatim; what changes is the
+  induction scaffolding and module order (a new
+  `Theory/Typing/Strengthening.lean` layer between `Strong.lean` and a
+  slimmed `UniqueTyping.lean`, with `ChurchRosser`/`HeadReduction`
+  re-founded above it).
+
+Two genuinely new proof cores (the research content):
+
+1. **S-NE core** — `NormalEq`/`StructEq` strengthening at lift endpoints
+   without `weakN_iff`, mutual with `NormalEq.trans` (whose eta-eta case
+   :896 consumes it on the same terms — `meas` is lift-invariant, so a
+   lexicographic (depth, meas, derivation) measure is the candidate).
+   Case analysis is fully mapped: `refl`/`appDF`/`etaL/R` need S1;
+   `lamDF`/`forallEDF`/`proofIrrel` need S2 one depth down; `structural`
+   needs the structEta-family lemma (the erstwhile oracle field).
+2. **Depth-bounded subject reduction** — the CR core at depth `d` must
+   keep reducts/normal forms inside a controlled depth. This is the same
+   frontier the 16C′ SExpr leaf is currently closing ("vertex retyping
+   bounded by the registered-rule stratification certificates"); the
+   Theory mirror will need its analogue. Treat 16C′'s resolution as the
+   template before attempting.
+
+One open design decision inside SST — **`.extra` certificates**
+(S-PR/`WHRed.weakU_inv` residual): the pattern-action equality
+certificates are lift-pairs after `apply_liftN` rewriting, but the match
+pieces are not structurally smaller than the original endpoints, so
+re-strengthening them lacks an obvious measure. Two candidate repairs,
+decide before proof text (two-strikes): (a) thread base-context
+certificates through the standardization as data (the Theory analogue of
+the SExpr note at SExpr.lean:3790-3796, "restate `Action.checked`/`sound`
+at `:↑`"); (b) justify a measure through the reduction sequence. (a) is
+recommended: it is a rule-packaging change, not a proof search.
+
+## 6. Staged obligations (Lean statements in `plans/probes/probeE-weakn.lean`)
+
+| # | Statement (probe name) | Difficulty | Discharged by | Probe status |
+|---|---|---|---|---|
+| W0 | `probe_wall_witness` | short proof | `IsDefEq.beta` + `inst_lift` | **proved, clean** |
+| W1 | `IsDefEqU.strengthen_of_witness` (forward under inhabited insertion) | short proof | `IsDefEq.instN` + `inst_lift` | **proved, clean** |
+| W2 | `HasType.weakN_inv_ex` (S1: typing strengthening, existential type) | real work (inside SST; blocked standalone) | per-depth CR core + W3; app case = Pi-obs, lam/forallE cases = S2 one depth down | type-checked, sorry |
+| W3 | `IsDefEqU.weakN_inv_sort` / `weakN_inv_forallE` (S2-obs at heads) | real work | re-founded `reduce_sort`/`reduce_forallE` + `WHRedS.weakU_inv` + soundness; Injectivity endpoints | type-checked, sorry |
+| W4 | `ParRedS.weakN_inv` (S-PR) | real work → research-grade pending the `.extra` decision (§5) | existing `ParRed.weakN_inv` structural cases + certificate re-packaging | tainted-proved (iteration); `.extra` residual open |
+| W5 | `NormalEq.weakN_inv` (S-NE) | **research-grade core** | new mutual induction (§5.1) | tainted-proved via `weakN_inv_DFC` (stand-in); clean re-proof owed |
+| W6 | CR-core re-founding per depth (`NormalEq.trans`, `church_rosser`, `ParRedS.standard`; no new statements) | **research-grade core** | existing scripts + depth scaffolding + §5.2 | n/a (refactor) |
+| W7 | `IsDefEqU.weakN_inv_staged` (assembly) | consumption | W2+W4+W5 + `church_rosser` | **tainted-proved** (dataflow certificate) |
+| W8 | `IsDefEqU.weakN_inv_probe` (= O1, bare `VEnv.WF` form) | outside this leaf | W7 at `[Params][Params.Extension]` + generic instance construction (shared debt with `sort_inv`, roadmap L4L-16E "closes from the instances") | type-checked, sorry |
+
+Measured closures (probe run 2026-08-15, `lake env lean`, exit 0, first
+attempt): `probe_wall_witness` and `IsDefEqU.strengthen_of_witness` at
+`[propext, Quot.sound]` — no `sorryAx`; `IsDefEqU.weakN_inv_staged` at
+`[propext, sorryAx, Classical.choice, Quot.sound]`; the only sorry
+warnings are the four intended heads (W2, W3a, W3b, W8). `ParRedS.weakN_inv`
+and `NormalEq.weakN_inv` elaborate fully (tainted through their inputs as
+documented).
+
+Inputs assumed available (not counted above): Injectivity.lean's three
+sorried endpoints (16C′ co-deliverables), the two `NormalEq.parRed`
+`.extra` holes (ChurchRosser.lean:1759/1778, L4L-18A), and the generic
+`Params`/`Params.Extension` instance (L4L-18A′/D-series).
+
+## 7. Execution order and sequencing recommendation
+
+**Can start now, before the 16C′ leaf closes** (all against stable
+sorried inputs):
+1. The `.extra` certificate design decision (§5, option (a) recommended) —
+   it also unblocks the SExpr mirror's :3810 sorry, a 16E pre-promotion
+   item.
+2. The SST module-order plan: name the new layer, enumerate the exact
+   theorem moves out of `ChurchRosser`/`HeadReduction`, and the
+   depth-indexed statements of `NormalEq.trans`/`church_rosser`.
+   (Pure planning; no proof text.)
+3. W5's case skeleton against the sorried W2/W3 heads (they are frozen
+   in the probe).
+
+**Waits for 16C′ leaf:** taint removal on Injectivity endpoints; the
+depth-bounded subject-reduction template (§5.2).
+
+**Waits for / merges with L4L-18A:** the two parRed `.extra` holes; the
+live and generic instances; W8.
+
+**Roadmap consequence (the actionable verdict):** `weakN_iff` forward
+should move off the 16E gate. 16E lands: this design, the probe (W0/W1
+proved, all heads pinned), and the re-scoped promise that the four
+`Params` inversion fields will be *proved* by SST rather than supplied at
+instance time. The sorry stays allowlisted through 16E and closes in an
+"18A′-SST" slice. The alternative — holding 16E open for 3–6 weeks of
+research-grade work whose prerequisites (18A extra holes, generic
+instances) are themselves later milestones — inverts the ladder's
+dependency order twice.
+
+## 8. Effort estimate
+
+- W0/W1: done (this pass).
+- W2+W3: ~3–5 days inside SST once the scaffolding stands.
+- W4: 2–4 days if design (a) is taken; unknown under (b).
+- W5+W6: the cores — 2–4 weeks combined, high variance; the two named
+  risks are the (depth, meas, derivation) termination argument for
+  S-NE×trans and the Theory analogue of 16C′'s depth-bounded retyping.
+- W7: hours (already written).
+- W8: not this leaf's budget (shared instance-generalization debt).
+
+Total for the forward proof proper: **3–6 focused weeks**, research-grade,
+after its 16C′/18A inputs; plus the shared instance debt for the bare-WF
+form. If a cheaper proof exists, it is not visible from the current
+codebase's vocabulary — every elementary route has a machine-checked or
+line-cited obstruction above.
diff --git a/plans/l4l-16c-adequacy-log.md b/plans/l4l-16c-adequacy-log.md
new file mode 100644
index 00000000..1bd9d860
--- /dev/null
+++ b/plans/l4l-16c-adequacy-log.md
@@ -0,0 +1,437 @@
+# L4L-16C adequacy attempt log
+
+This file preserves the working-notes narrative that accumulated in
+`plans/roadmap.md`'s L4L-16 ladder entry between 2026-08-12 and
+2026-08-13, moved here when the 2026-08-13 audit re-cut the milestone
+(`plans/l4l-16-completion-plan.md`). It is a historical record of the
+repair sequence at the adequacy iota leaf — valuable precisely because it
+documents the repeated erased-type-alignment discoveries that motivated
+the O1/O2/O3 decomposition — and is not status-bearing.
+
+## Original L4L-16A bullet (roadmap, as of 2026-08-13 04:32)
+
+*L4L-16A — bridge interface and judgment translation.* Largely
+implemented in the uncommitted working copy (audited 2026-08-12): the
+SExpr `Params` class is proof-carrying (`extra_pat` deleted), the
+five-field `Params.Semantic` bridge interface
+(`structureEta`/`ctor`/`defn`/`registered`/`iotaSite`) packages the
+environment-specific obligations, `VEnv.IsDefEqStrong.mkS` translates
+the current Theory judgment — including `IsDefEq.structEta` — at
+`[propext, Quot.sound]`, `IsDefEqStrong.defeq` and `Params.ctor_ty` are
+proved, and `VEnv.IsDefEqU.sort_invS` states the endpoint with no
+project axiom. The remaining L4L-16A cleanup is complete in the working
+copy: `Experimental/UniqueTyping.lean` now exposes only the valid strong
+sort-uniqueness compatibility theorem, while the four pre-broken,
+unreferenced prototypes are explicit import-compatible parked stubs.
+
+(Correction recorded at the 16B′ checkpoint: `Params.Semantic` has six
+fields — the bullet above omitted `iotaRule`.)
+
+## Original L4L-16B bullet
+
+*L4L-16B — SExpr infrastructure closure.* Discharge the remaining
+SExpr-side admissions, which are no longer
+`strong`/`defeq`/`ctor_ty` but: substitution (`IsDefEqLift.subst`),
+reduction/typing soundness (`WHRedS.defeq`,
+`InferType.hasType`/`whRed`, `InferTypeS.hasType`, the `.extra` cases
+of `WHRed.subst`/`weakU_inv`), `CRDefEq.trans`, and `ShapeLogRel`'s
+`Shape.WF.plift`, whose `stop` tactic must become a proof or an
+explicit sorry. The generic substitution-container repair is
+kernel-checked in the working copy: `Ctx.Subst.lift_r`, `lift`, `id`, and
+`one` now take the weakening/variable operations they actually require,
+and `Ctx.SubstEq.ofLift` supplies the binder-stable equality embedding.
+The under-specified `NormalEq.appDF` constructor now carries equality of
+its two instantiated codomains; this makes the application cases of
+`NormalEq.symm` and `NormalEq.weak'` kernel-checked rather than opaque
+transports. `CRDefEq.trans` and the remaining reduction/typing admissions
+are still open.
+The live stratified-S `mono`, `to_core`, and `isType` admissions are also
+discharged. Same-substitution `IsDefEq.subst`, heterogeneous
+`IsDefEqStrong.substCongr`/`subst`, and context conversion
+`Lookup.defeqDF_l'`/`IsDefEq.defeqDF_l'` are now kernel-checked. The
+three-way substitution interface is `Ctx.SubstEq`, and `LRS.PiInstDefEq`
+retains both the semantic codomain edge and its raw SExpr congruence.
+`Ctx.Subst.imp` now transports substitution evidence, and a genuinely
+typed substitution transports an entire proof-carrying
+`Pattern.Action`; consequently `WHRed.subst` and `WHRedS.subst`, including
+the generated-rule `.extra` branch, are kernel-checked under the narrowed
+SExpr-typing premise. `SExpr.SpineDefEq` now records a dependently typed
+pointwise equality between two application spines, with checked head
+congruence, left-spine projection, and reflexive construction from
+`SpineWF`; this is the raw alignment layer needed by the paired generated
+RHS certificate.
+`IsDefEqLift.subst` remains open because its old polymorphic
+`Ctx.Subst HasType` premise permits an arbitrary `HasType` relation and is
+therefore not a sound theorem statement; narrow that interface to lifted
+SExpr typings before proving it.
+
+(Corrections recorded at the 16B′ checkpoint: the `Shape.WF.plift`
+"`stop` tactic" claim was stale — the whole prototype was inside a block
+comment, never elaborated, with zero consumers; and `WHRed.subst`'s
+`.extra` case was already kernel-checked, only `weakU_inv`'s remained.)
+
+## Original L4L-16C bullet — the attempt history
+
+*L4L-16C — constant adequacy.* Close the `LR.adequacy` constant
+branch: the definition-body evaluation route is token-closed but leans
+on the circular `hDef` premise noted below, and one admission remains
+at the reached pattern leaf. The structural `Const.lam` recursion is
+now kernel-checked: it transports the related application spine and Pi
+edge into `LR.constDefEq`, which discharges every semantic
+`bot`/`lam`/`ctor`/`indTy` case and follows the well-founded `R` child.
+The working copy now
+makes the local evidence boundary finite and uniform: `Pattern.Action`
+bundles membership, the exact match/captures, discharged checks, and the
+concrete local equality; `IsDefEqStrong.extra`, `WHRed.extra`, and
+`ParRed.extra` all consume that one certificate, its weakening transport
+is proved once, and both semantic soundness and adequacy consume it without
+recovering soundness from membership. The zero-arity definition bridge
+constructs an `Action` explicitly. The first half of the nonzero leaf
+contract is also kernel-checked: `LRS.CaptureDefEq`,
+`LE_Interp.Matches.varN_materialize`, and
+`LE_Interp.Matches.iota_materialize_exact` turn exact related recursor and
+constructor spines into the two concrete `MatchesS` witnesses, retain a
+typed logical-relation witness for every capture, and lift major-premise
+reductions under the recursor spine. The iota lemma deliberately keeps
+recursor captures at depth `n+1` and constructor fields at depth `n`.
+The transport-aware closure API is now kernel-checked as
+`LRS.CtorDefEq.Algebra`/`fold`: its `.unlift` handler receives the already
+folded high-level result, making pointwise projection of arbitrary refined
+fields unavailable by construction. The evaluator now also carries the
+invariant that its accumulated related spine is nonempty. The checked
+`LE_Interp.Matches.iota_of_pat_nonempty` inversion excludes definition
+patterns at the leaf, and `LR.PatternLeafDefEq`/`LR.IotaLeafDefEq` name the
+exact boundary with a checked adapter between them. `LR.DefEq.ctor'_inv`
+now uses the iota constructor's `.ctor` classification to rule out the
+eta-collapse branch of `WShape.ctor'` and exposes the exact
+`LRS.CtorDefEq` witness needed by the fold. Thus the remaining admission is
+no longer polymorphic over definitions and iota rules: it is exactly the
+iota leaf, whose finite contraction and generated-RHS congruence are now
+separate obligations. A subsequent interface audit found that the former four
+`Params.Semantic` fields could not recover a certified nonzero rule, its
+checks, or a typed local action from an arbitrary `Params.Pat` witness.
+The former provisional `iotaAction` obligation has now been replaced in
+the working copy by the evidence-rich `iotaSite` contract.  Its
+`Pattern.IotaTyping` input retains the typed recursor and constructor
+spines (with the exact constructor levels), while
+`Pattern.IotaReductionSite` exposes the registered tower, typed capture
+spine, beta collapse, checks, and RHS computation.  The generic
+`IotaReductionSite.action` construction applies the registered equation
+along that spine, so the bridge no longer returns a contraction oracle or
+any logical-relation conclusion. Every
+SExpr now also has a chosen well-formed Theory representative
+(`SExpr.reify`), semantic pattern matches reify to exact Theory matches, and
+RHS application commutes with that representation. `LR.constDefEq` carries
+the accumulated raw equality and result-type validity down to the leaf.
+Finally, `LR.iotaActions_of_exact` conditionally combines exact related recursor and
+constructor spines with that bridge to construct both concrete actions,
+pointwise capture relations, and both full weak-head reduction paths to the
+instantiated RHSs.  The fold-facing form is now kernel-checked without a
+canonical-relation assumption: `LRS.CaptureDefEqAt`,
+`LE_Interp.Matches.varN_materializeAt`,
+`LE_Interp.Matches.iota_materialize_exactAt`, and
+`LR.iotaActions_of_exactAt` keep constructor captures in an arbitrary `IH`
+and recursor captures in `LRS IH`; the older existential-depth theorems are
+wrappers over that adjacent-level API.  `LRS.IotaRHSDefEq` names the
+intended evidence-only congruence boundary for the fold. A second
+interface audit pins the missing live premise:
+semantic `MatchesS` erases the constructor levels, while
+`BlockGenerationChecked.pat_wf` requires the rule-instantiated constructor
+levels and typed recursor, constructor, and capture spines. Bare SExpr
+self-typing cannot recover those data without application/type inversion.
+The accumulator now carries `SExpr.SpineWF` certificates for both recursor
+applications, and `LRS.CtorDefEq.exact` retains both typed constructor
+spines and their head typings through the transport-aware fold. A leaf
+audit now shows that the provisional `LRS.IotaRHSDefEq` statement still
+erases one essential fact: at a variable RHS leaf the capture witness has
+its own existential SExpr type, but the contract supplies no alignment
+between that type and the whole RHS equality's type. Weak type uniqueness
+cannot manufacture that alignment before L4L-17. The next local boundary
+is therefore to retain a typed RHS/capture alignment witness in the
+reduction site (or equivalently narrow the congruence contract). The raw
+dependent-spine half of that boundary is now `SExpr.SpineDefEq`; the next
+step is to retain the ordered generated capture paths and their exact
+codomain/semantic alignment.  The transport core for that continuation is
+now kernel-checked: `LRS.DefEq.app` is polymorphic in the predecessor
+relation, `LogRel.LiftEquiv` packages the two fold transport laws, its
+`trans` and base-origin-only `cancelRight` operations compose/cancel those
+laws without projecting arbitrary high refinements, and `succ` transports
+the package through one `LRS` layer.  Capture and constructor-argument
+witnesses rebase through the same package.  The accumulator now packages
+its final application as `LR.PatternLeafSpine`: the raw last-Pi
+certificate, the major's logical relation at that exact domain, the
+remaining recursor arguments, and the semantic Pi edge are one dependent
+witness.  This package is threaded through every recursive
+`LR.constDefEq` lambda layer, and the focused adequacy target is green with
+that stronger invariant.  A fold audit then exposed the remaining
+non-root gap: `LRS.CtorDefEq.trans` deliberately erases the SExpr type of
+its midpoint, so two exact constructor leaves can carry unrelated
+existential field types even when their shared midpoint syntax agrees.
+Neither the aligned capture relation nor the generated-RHS application
+chain can compose those leaves without a type alignment, and the current
+coarse `LRS.TyDefEq.indTy` supplies only two `IndTyHead` witnesses.
+Retrying the rejected type-indexed `CtorDefEq` encoding merely moves the
+same issue to untyped weak-head subject expansion.  The next repair must
+therefore retain a composable canonical field-type alignment in exact
+constructor observations (derived from the live constructor certificate),
+or explicitly promote the required limited uniqueness lemma from L4L-17;
+it must not manufacture the midpoint type.  Once that boundary is
+kernel-checked, construct the repaired contract over `LE_Interp.recR`,
+instantiate `LRS.CtorDefEq.fold`, close the leaf, and replace the circular
+constant `hDef` premise with its live-environment construction. The
+accumulator typing currently inherits the
+open L4L-16B `WHRedS.defeq` obligation; `IsDefEq.subst` itself is now
+kernel-checked. The
+continuation's `.unlift` case must
+lower the whole result; arbitrary high-level field refinements cannot be
+projected pointwise without reviving the rejected `Shape.WF.plift`
+principle.
+
+(Correction recorded at the 16B′ checkpoint: the `hDef` premise is a
+field of `IsDefEqStrong.const` discharged by `mkS` from
+`Params.Semantic.defn`; its live construction is the 16D `defn` field,
+not separate 16C work.)
+
+**Joint normalization audit, 2026-08-13.** The limited-uniqueness
+implementation split cleanly into global `RawTypeUniq` plus the one
+successor-only, term-indexed `LimitedUniq.LamRetype` case; the earlier claim
+that a generic assumption-free `Retype` handled lambdas was false.
+`PiTypeAlign` remains only an optional sufficient adapter, not a builder
+assumption, and `JointBuilder.succ` explicitly consumes lower adequacy. The exact-leaf
+audit also found that `CtorExact` had not related its two universe-level
+lists. Both construction sites already pass one list, so the certificate now
+stores `ls = ls'`. A native leaf can therefore export an ordinary typed
+equality. `CtorPath.foldRaw` retypes every link at one externally chosen
+domain and threads the right endpoint typing through the path;
+`CtorChain.foldRaw` and `CtorDefEq.foldRaw` add exactly two root-view typing
+callbacks. Their measured closure is
+`[propext, Classical.choice, Quot.sound]`, as is the native exact iota
+handler. Thus intermediate links are no longer implicated in
+`WHRedS.defeq`; only arbitrary weak-head expansion at the two roots remains.
+
+A later consumer audit found one further separation: a framed exact iota
+handler runs at its native relation, while the recursor prefix and result
+typing remain at the canonical root relation. Arbitrary high extensions of a
+common lower relation agree only on lifted lower shapes, so the root prefix
+cannot be projected through a general `unlift` frame. Constant evaluation now
+returns a synchronized `LogRel.DefEqRect` containing both endpoint
+self-relations and the cross-relation. The open semantic consumer is
+therefore the generated fixed-head application chain at the canonical root;
+native normalization remains responsible for raw constructor/capture
+materialization, not for transporting that root prefix.
+
+The same audit invalidated the claim that O3 could be built independently
+from `LE_Interp.recR`. The existing `IotaRHSDefEq` inputs do not contain the
+fixed RHS head's logical validity or the intermediate semantic Pi telescope.
+Those facts must be carried by the surrounding semantic-`R` induction; they
+cannot be reconstructed from raw `PathSpineWF` and final result validity.
+The syntactic half is now discharged without a new bridge field:
+`Params.Semantic.closedHasTypeStrong` reifies any semantic level list,
+instantiates and weakens an ordered-environment closed Theory typing, and
+translates it back to SExpr. `Pattern.IotaRule.rhsStrong` applies it to the
+registered fixed RHS. Both declarations measure at
+`[propext, Classical.choice, Quot.sound]`; only logical head adequacy and the
+semantic Pi application chain remain for the repaired O3 contract.
+
+**Heterogeneous-transitivity retirement, 2026-08-13.** The raw and strong
+SExpr `trans'` constructors are now gone. `SpineWF` and `SpineDefEq`
+concatenate conversion-aware spines without composing conversions whose sort
+indices may differ. The only downstream semantic use was successor
+`TyDefEq.trans` at Pi shape; its domain and codomain equalities now use
+nonempty `TypeDefEqPath`s. Paths reverse, concatenate, transport judgments,
+and convert binder contexts one individually typed edge at a time. Once
+`RawTypeUniq` is available, `TypeDefEqPath.collapse` aligns each shared
+endpoint's two universe assignments and recovers one ordinary equality.
+`ContextualRawTypeUniq` and `LR.ContextualJointBuilder` expose exactly the
+well-formed-context package needed to repeat that collapse under a Pi binder;
+`forallE_whRed_l_of_adequacy_collapsed` and
+`forallE_inv_of_adequacy_collapsed` check the complete handoff. The full
+`ShapeLogRelAdequacy` target is green. Path operations and collapse audit at
+`[propext, Quot.sound]`; path-valued/collapsed adequacy inversion and the new
+weak-to-strong reflection bridge stay within
+`[propext, Classical.choice, Quot.sound]`. No `sorryAx` is introduced by this
+retirement. The sole adequacy admission remains the iota leaf and now has a
+sharper implementation constraint: its constant evaluator must retain the
+abstract semantic `R` proof so `LE_Interp.recR` can supply fixed-head logical
+adequacy, rather than first erasing provenance through `Const.mono`.
+
+**Proof-relevant recursion refinement (2026-08-13).** Fixed-head
+self-validity has two semantic inputs, but pairing two proof-indexed
+`LE_Interp` recursors does not retain evaluator provenance: `LE_Interp` is a
+`Prop`, so proof irrelevance identifies derivations that selected different
+constant relations. Focused elaboration probes additionally showed the
+binary homogeneous predicate cannot simultaneously support conversion to an
+arbitrary displayed type and the term/type role swap at application. Thus
+`recRDeep₂` remains correct only for proof-independent consumers and is not
+the leaf's evaluator recursion principle.
+
+The repaired boundary is `LE_Interp.Witness`, a proof-relevant mirror chosen
+from every public interpretation. Its constant case stores one relation and
+the matching `R → Witness` callback; `Witness.recR` follows exactly those
+edges, `Witness.mono` preserves the chosen tree, and
+`Lower.realizeWitness` converts a lower evaluator result back through the
+same callback. The complete witness/forgetful layer kernel-checks and audits
+at `[propext, Classical.choice, Quot.sound]`. The adequacy constant branch now
+destructs the chosen witness directly. Fixed RHS selection is packaged by
+`RHS.fixedWitness` and `fixedLowerWitness`; `Witness.closed` preserves the
+chosen tree while changing valuations for closed registered heads;
+`Witness.mono_l` preserves it under valuation growth; `Witness.recDeep`
+supplies exact hypotheses for every ordinary/type/registered child;
+`Witness.recDeep₂` nests two such trees while keeping first-side hypotheses
+polymorphic in the second, which covers the application term/type role swap;
+and
+`IotaRHSDefEq.of_nonbotWitness` delivers that exact head witness to the
+nonbottom generated-chain callback. These additions also audit at the clean
+baseline. The retained proof tree now also has a kernel-checked compatible
+merge: `RDeepChildren.JoinLaws` makes bottom, root lowering, valuation growth,
+and exact recursive-result join explicit, and proof-relevant `compat_join`
+keeps the chosen joined constant callback synchronized with its retained
+tree. Binder saturation and generic self-typing are now closed as well:
+`RDeepChildren.Laws`, `TypedRDeep.lam`, and `TypedRDeep.forallE` retain the
+package under binders; Nat-first `recNatRDeep`/`recNatRDeep₂` make conversion
+restart only after a strict stratification-depth decrease; and
+`FitsRDeep`/`SoundRDeepAt`/`soundRDeepRestart`/`recNatRDeepSound` compile the
+full application, lambda, Pi, and conversion induction. The next leaf step
+is therefore only the consumer-specific fixed-head `buildP` application-chain
+algebra; `DefEqRect` continues to provide the structural transports for its
+proof-independent result.
+
+## Roadmap 16C′ narrative moved here (2026-08-14 cleanup)
+
+Moved verbatim from the roadmap ladder bullet per completion-plan
+guardrail #4 (roadmap is status, not lab notebook). This is the
+chronological continuation of the entries above; overlap with the
+completion plan's design sections is intentional.
+
+**Progress, 2026-08-13:** step (1)'s
+interfaces are kernel-checked: `LR.AdequacyAt`, `LR.JointStage`, and
+the corrected offset `LR.JointBuilder` validate the level dependency;
+the initial same-level `uniqOfAdequacy` draft was rejected because bottom
+shapes erase typing evidence and it omitted target-context validity. The
+public Pi/sort
+inversions factor through level-indexed adequacy; and `mk` reflection
+is fixed at `VEnv.EqUpToLevels` (not false syntactic injectivity).
+Step (2) is also kernel-checked: native exact `CtorLink`s carry unary
+root frames, nonempty `CtorPath`s concatenate through classified-spine
+determinism, and `CtorDefEq.toChain` covers every free-closure
+constructor with a proved round trip. A three-operation
+`CtorChain.Algebra` now exposes only native exact leaves, composition,
+and root anchoring to the eventual uniqueness-aware consumer;
+`CtorChain.NativeAlgebra` makes the well-founded order explicit by
+completing each native leaf, folding its transport frame back to the
+root, and only then composing at the root with predecessor uniqueness.
+Thus `unlift` never requests uniqueness for arbitrary high-level fields.
+A later consumer audit clarified that this order normalizes constructor
+evidence but does not alone close iota: the exact handler's native relation
+cannot consume the canonical-root recursor prefix through an arbitrary
+lift/unlift zigzag. Such a zigzag agrees only on lifted lower shapes, not on
+unrelated high refinements.
+The subsequent raw audit found and fixed one omitted invariant:
+`CtorExact` now records equality of the two constructor universe-level
+lists (both live producers already supplied the same list). Native leaves
+therefore expose an ordinary typed equality. `CtorPath.foldRaw`,
+`CtorChain.foldRaw`, and the `CtorDefEq.foldRaw` adapter retype and compose
+every native edge at one recursor domain using `RawTypeUniq`; their axiom
+closures are exactly `[propext, Classical.choice, Quot.sound]`. The two
+root `CtorView`s are explicit subject-reduction callbacks, not hidden in
+normalization. The native exact iota theorem is independently measured
+clean. The callbacks were subsequently discharged from
+`JointStratifiedInversion`, as recorded below.
+The step
+(3) spike resolved its
+open q1 negatively: `InferType.app` needs an actual weak-head reduction
+from the inferred function type to a Pi, while a weak conversion supplies
+only definitional equality; deriving the former is Church–Rosser-strength.
+The same audit rejected treating `IotaRHSDefEq` as route-independent:
+`PathSpineWF` alone does not provide the fixed RHS head's logical validity
+or the intermediate semantic Pi telescope. That evidence must be an
+induction hypothesis of the surrounding `LE_Interp.recR` construction.
+Its syntactic typing is no longer missing:
+`Params.Semantic.closedHasTypeStrong` reifies the semantic level list,
+strengthens the ordered-environment Theory typing, and translates it back;
+`Pattern.IotaRule.rhsStrong` specializes this to the registered RHS, with
+the clean standard axiom closure.
+The heterogeneous raw/strong `trans'` constructors have also been removed
+rather than treated as an interim oracle. Conversion-aware spines now
+append structurally, and successor Pi type validity retains a nonempty
+`TypeDefEqPath` of ordinary typed equalities. `TyDefEq.trans` concatenates
+those paths; `TypeDefEqPath.collapse` consumes `RawTypeUniq` only at the
+promotion boundary. `LogRel.ContextualRawTypeUniq` plus
+`LR.ContextualJointBuilder` provide the well-formed extended-context form,
+and the level-indexed `_collapsed` Pi-inversion adapters kernel-check the
+domain/codomain handoff. The full adequacy target remains green; path
+operations/collapse audit at `[propext, Quot.sound]`, while reflection and
+adequacy inversion remain at the standard
+`[propext, Classical.choice, Quot.sound]` baseline.
+A subsequent recursion-boundary probe rejected the shallow `RChildren`
+contract: symmetry and transitivity transport the current semantic proof
+but not its `R`-child induction hypotheses.  `LE_Interp.RDeepChildren` and
+`LE_Interp.recRDeep` now kernel-check the corrected lexicographic interface:
+ordinary semantic children retain provenance, while abstract constant
+edges additionally receive the full recursive hypothesis.  The matching
+`HasTypeStratifiedS.forallE_inv` exposes strictly shallower domain/codomain
+typings.  This also found and fixed a context-order bug in the joint tower:
+contextuality now lives inside every `JointStage`; it is no longer a wrapper
+around fixed-context builders, which could not enter `A :: Γ` while proving
+uniqueness.  These declarations audit at the standard clean baseline.
+The full syntactic consumer is now complete too:
+`JointStratifiedInversion` packages the exact sort/Pi observations and
+`IsDefEq.uniq_of_stratified_inversion` derives contextual raw uniqueness by
+well-founded induction on stratified typing depth.  It then proves
+`WHRed(S).defeq_of_stratified_inversion`; the beta and registered-step cases
+are no longer open.  `CtorDefEq.foldRaw_of_jointBuilder` supplies both root
+callbacks and derived uniqueness to the normalized chain.  All audit at
+`[propext, Classical.choice, Quot.sound]`.  The base bootstrap is complete:
+positive adequacy transports sort/Pi observations across heterogeneous
+`TypeDefEqPath`s, derives stratified path uniqueness, and only then collapses
+the paths.  Contextual raw uniqueness and direct stratified inversion now
+follow from level-one adequacy, so `JointBuilder.invZero` has been deleted.
+The merged milestone has also replaced the over-strong successor
+`PiTypeAlign` requirement with exact, term-indexed `LamRetype`, made lower
+adequacy an explicit input to `JointBuilder.succ`, and changed constant
+evaluation to return synchronized `LogRel.DefEqRect`s (both endpoint
+self-relations plus the cross-relation). The remaining step is the
+canonical-root application-chain proof for the fixed iota head, followed
+by the semantic leaf fold. A focused probe rejected the initially paired
+proof-indexed recursion boundary: because `LE_Interp` is a proposition,
+proof irrelevance erases which abstract constant relation an evaluator
+chose, and the homogeneous pair also cannot cover both conversion and the
+application term/type role swap. `LE_Interp.Witness` now supplies the
+proof-relevant internal tree, with exact constant callbacks, monotonicity,
+index-only recursion, and lower-result realization; forgetting it recovers
+the public interpretation. The layer kernel-checks at
+`[propext, Classical.choice, Quot.sound]`. `recRDeep₂` is retained only for
+proof-independent consumers. The chosen witness is now threaded through
+the live adequacy constant case: downward-closed fixed RHS selection,
+valuation/closed transport, unary and binary proof-relevant child
+recursion (including term/type role swaps), and the witness-aware
+nonbottom iota adapter all kernel-check at the same
+baseline. The retained-tree transport layer now also covers predicate
+mapping, syntactic lift/weakening, substitution/instantiation, and exact
+Pi/lambda inversion.  A proof-relevant `TypedRDeep` package has been
+kernel-checked through dependent application and forgets back to the
+existing `InterpTyped`; this proves that application introduces no fresh
+semantic recursion edge.  The finite compatible join used by
+lambda/forall saturation is now kernel-checked as well:
+`RDeepChildren.JoinLaws` exposes bottom, root lowering, valuation growth,
+and exact recursive-result join, while proof-relevant `compat_join`
+synchronizes the selected joined witness with its retained tree (including
+the constant evaluator callback).  These declarations audit at
+`[propext, Classical.choice, Quot.sound]`. Binder-compatible saturation is
+now complete too: `RDeepChildren.Laws`, `TypedRDeep.lam`, and
+`TypedRDeep.forallE` retain exact trees through weakening and both binders.
+Conversion forced the correct lexicographic order; the new Nat-first
+`recNatRDeep`/`recNatRDeep₂` permit an arbitrary witness restart only after
+the stratification depth falls. `FitsRDeep`, `SoundRDeepAt`,
+`soundRDeepRestart`, and `recNatRDeepSound` then kernel-check the entire
+syntax-directed retained-typing induction, including conversion, at the
+same baseline. The remaining proof body is the consumer-specific `buildP`
+algebra that produces the fixed-head logical application chain. Its core
+dependent-application handoff is now factored as the admission-free
+`LR.adequateApp`: exact function, argument, and instantiated-result
+callbacks close the full shape join at
+`[propext, Classical.choice, Quot.sound]`, and the retained self-typing
+probe reuses it without another evaluator assumption. The remaining
+consumer work is the conversion/type-relation handoff and constant case,
+followed by `of_nonbotWitnessResult` and the semantic leaf fold. The sole
+adequacy admission remains open until that fold lands.
diff --git a/plans/l4l-16c-buildp-premortem.md b/plans/l4l-16c-buildp-premortem.md
new file mode 100644
index 00000000..8e25b012
--- /dev/null
+++ b/plans/l4l-16c-buildp-premortem.md
@@ -0,0 +1,4225 @@
+# L4L-16C buildP pre-mortem: gap map for the final adequacy-leaf step
+
+## Worker resolution (2026-08-14, after review integration)
+
+The signature audit was correct to stop the leaf-local draft.  The moving
+working tree now resolves the mapped gaps as follows:
+
+- **G1 is closed.** `FixedHeadResult` and
+  `iotaDefEq_of_ctorExactAt_fixedHead` no longer require `Ctx.WF`; the
+  target-context well-formedness dependency belongs only at the joint
+  uniqueness/root-reduction boundary.
+- **The old G2 obligation is obsolete.** The retained consumer uses
+  `RDeepChildren (fun _ => True)`, whose laws are already complete; it does
+  not require a `Laws FixedHeadResult` instance.
+- **G3 exposed an additional depth mismatch, now repaired.**
+  `FixedHeadResultAt hX depth` is retained at the same Nat index as
+  `SelfAdequateAt`; `FixedHeadStep` receives that freshly constructed
+  same-depth self-adequacy result.  Only after the Nat-first recursion has
+  produced every depth does `FixedHeadResult.of_forall_at` recover the old
+  depth-polymorphic contract.  The adequacy module builds after this change.
+- **G4 chooses route 2.** Route 1 cannot instantiate the existing
+  `CtorChain.NativeAlgebra` safely: a native exact link is stated in an
+  arbitrary relation `J`, while
+  `iotaDefEq_of_ctorExactAt_fixedHead` is stated in canonical `LR` at both
+  the recursor prefix and generated RHS.  An `unlift` frame does not permit
+  projecting arbitrary high-level fields or the canonical prefix into `J`.
+  Thus a uniqueness-free leaf-local fold would recreate the already rejected
+  native/root projection.  The main adequacy construction must expose the
+  predecessor limited-uniqueness/lower-adequacy package through the existing
+  level-indexed joint boundary; it must not manufacture a completed
+  `JointBuilder` inside the current direct induction.
+- **G5 remains live** and is part of the fixed-head application-chain proof,
+  not an admissible raw-to-semantic conversion shortcut.
+
+This resolution supersedes the alternatives in G4 below; the rest of the
+document remains as the snapshot evidence that motivated it.
+
+Purpose: before the worker writes the "consumer-specific fixed-head `buildP`
+application-chain algebra" (the last named obligation per
+`plans/l4l-16c-adequacy-log.md` final entry and
+`plans/l4l-16-completion-plan.md` §3 line 649), map exactly what that step
+must consume, whether each input is actually available at the sorry site,
+and where erasure-failure-mode #7 could hide. All claims carry file:line
+references to the snapshot below. Uncertainty is flagged inline; nothing
+below was elaborated through Lean (read-only analysis).
+
+## Snapshot (MOVING TARGET — verify before relying on line numbers)
+
+Read window: 2026-08-14 ~03:35–03:55 EDT. A worker session is actively
+editing these files; mtimes were checked at the start and end of the read
+session and did not change in between, so all line numbers are consistent
+with this exact state:
+
+| file | mtime | size |
+|---|---|---|
+| `Lean4Lean/Experimental/ShapeLogRel.lean` | 2026-08-14 01:21:27 | 583544 B |
+| `Lean4Lean/Experimental/ShapeLogRelAdequacy.lean` | 2026-08-14 03:31:07 | 181248 B |
+| `Lean4Lean/Experimental/SExpr.lean` | 2026-08-13 13:07:35 | 182986 B |
+
+Sole adequacy-file sorry: `ShapeLogRelAdequacy.lean:3058`. (SExpr.lean has
+four separate sorries at 3516/3739/3842/3908 — L4L-16B′ scope, not this
+leaf.) Re-locate after any edit with
+`grep -n "sorry" Lean4Lean/Experimental/ShapeLogRelAdequacy.lean`.
+
+Abbreviations: SLR = ShapeLogRel.lean, ADQ = ShapeLogRelAdequacy.lean,
+SE = SExpr.lean. All Lean names live under `Lean4Lean.SExpr` unless noted.
+
+## The sorry site
+
+### Enclosing structure (outermost → innermost)
+
+1. `LR.adequacy` (ADQ:2856-2858): `(H : IsDefEqStrong Γ M N A) (hM :
+   LE_Interp ρ m.T M) (hA : LE_Interp ρ a.T A) (hmem : m.HasType a) :
+   Adequate Γ₀ Γ ρ M N A m a`, by `induction H generalizing ρ n m a`.
+   **No `Ctx.WF` premise anywhere in the statement.** `Adequate`
+   (ADQ:9-13) quantifies over `LR.SubstWF Γ₀ σ σ' Γ ρ`.
+2. `| @const c ci Γ ls u h1 h2 hTy F hF hDef ihTy ihF ihDef` (ADQ:2886).
+3. `cases hM.witness`, const branch (ADQ:2891):
+   `| @const _ _ ci' _ m' _ a' _ R hreg _ hle hm'ty hA' hConst hR`.
+   This binds the proof-relevant callback
+   **`hR : ∀ m e, R m e → LE_Interp.Witness ρ m e`** and
+   `hA' : LE_Interp.Witness ρ a' (mkInst ls ci.type)` (the registered
+   type's witness tree).
+4. `suffices`-block per substitution; `intro σ σ' W` with
+   `W : LR.SubstWF Γ₀ σ σ' Γ ρ` (ADQ:2893-2896).
+5. `hC : LE_Interp.Const c ls (LE_Interp.Lower R) [] m.T` (ADQ:2898-2899);
+   `cases hC with | lam hrec hlam` + `rename_i nsem hlen_sem fsem`
+   (ADQ:2902-2903). Per `LE_Interp.Const.lam` (SLR:3542-3543):
+   `hrec : ∀ x y : WShape nsem, (x, y) ∈ fsem →
+   LE_Interp.Const c ls (LE_Interp.Lower R) [x] y.T`.
+6. `hmem.unfold` lam branch `| @lam k f a₁ a₂ htm` (ADQ:2908); soundness
+   unpack of the constant's type (ADQ:2909-2915, the `toValTy` pattern);
+   `split <;> rename_i hf`, Pi-observation unpack
+   `⟨A₁, A₂, _, _, u₁, u₂, hred, _, hA₁, hA₂, hvalA₁, hpi⟩` (ADQ:2919).
+7. `have eval : ∀ {k'} (hn : k ≤ k') (hnsem hnArgs : nsem ≤ k') {x y p x₀
+   y₀}, p.HasType (a₁.lift k') → Γ₀ ⊢ x ≡ y : A₁ → (LR Γ₀).DefEq x y A₁ p
+   (a₁.lift k') → (x₀,y₀) ∈ fsem → x₀.lift k' ≤ p → (f.lift k').app p ≤
+   y₀.lift k' → (LR Γ₀).DefEq ((const c ls).app x) ((const c ls).app y)
+   (A₂.inst x) ((f.lift k').app p) ((a₂.lift k').app p)` (ADQ:2928-2937).
+   Inside: `hPiK hAK hout hchildLe hType₀ hTypePi hConstPi hAppTerm
+   hAppType hAppSpineX hAppCodomain hAppSpineY hA₁K hAppPair hAppAligned
+   hAppLeaf` (ADQ:2939-3020); `hAppLeaf : LR.PatternLeafSpine Γ₀ (LR Γ₀)
+   (mkInst ls ci.type) [x] [y] [p] (A₂.inst x) ((f.lift k').app p)
+   ((a₂.lift k').app p)` (ADQ:2997-3020).
+8. `evalPat : LR.PatternLeafDefEq Γ₀ c ls (LE_Interp.Lower R) :=
+   LR.PatternLeafDefEq.of_iota (by …)` (ADQ:3021-3059) — the sorry is the
+   tail of this by-block. After it, `eval` is consumed by `LR.constDefEq`
+   (ADQ:3060-3065) and wrapped into `LogRel.DefEqRect.diagonal` for
+   `LR.constLamDefEq` (ADQ:3066-3069) — diagonal suffices here because
+   both heads are the same `const c ls`.
+
+### Hypotheses introduced inside the `of_iota` block (ADQ:3027-3057)
+
+`of_iota` (ADQ:2178-2185) reduces `PatternLeafDefEq` to `IotaLeafDefEq`
+(ADQ:1302-1326) instantiated at `R := LE_Interp.Lower R`. The intro at
+ADQ:3027-3029 binds (types per ADQ:1304-1323):
+
+- `nI : Nat`, `rargsI : List (WShape nI)`, `rec major ctor arity`,
+  `rI : (RecursorIotaPattern rec major ctor arity).RHS × ….Check`,
+  `mcapI : ….Path → TShape`, `xsI ysI CHeadI AI : SExpr`,
+  `outI outTyI : WShape nI`
+- `hpatI : Params.Pat (RecursorIotaPattern rec major ctor arity) rI`
+- `hmatchI : LE_Interp.Matches (RecursorIotaPattern …) c rargsI mcapI`
+- `hrhsI : LE_Interp.RHS ls mcapI (LE_Interp.Lower R) outI.T rI.1`
+- `hleafI : LR.PatternLeafSpine Γ₀ (LR Γ₀) CHeadI xsI ysI rargsI AI outI
+  outTyI`
+- `htermI : Γ₀ ⊢ xsI.foldr app-fold (const c ls) ≡ ysI.foldr … : AI`
+- `hAIType : ∃ u, Γ₀ ⊢ AI : .sort u`;
+  `hheadI : Γ₀ ⊢ const c ls : CHeadI`
+- `hspineXI hspineYI : SExpr.SpineWF Γ₀ CHeadI xsI.reverse AI` (resp. ysI)
+- `houtI : outI.HasType outTyI`; `hAI : (LR Γ₀).TyDefEq AI AI outTyI`
+
+Then `cases hmatchI | @app fPat nCtor head recShapes mrec aPat ctorHead
+ctorShapes mctor hmfI hmaI` (ADQ:3030-3032) yields
+- `hmfI : LE_Interp.Matches (Pattern.varN (.const rec) major) rec
+  recShapes mrec` (recursor prefix, successor depth) and
+- `hmaI : LE_Interp.Matches (Pattern.varN (.const ctor) arity) ctor
+  ctorShapes mctor` (constructor, one depth lower);
+
+`rcases hleafI` (ADQ:3033-3037) destructures the `PatternLeafSpine`
+fields (ADQ:1144-1168): `majorX recXs majorY recYs majorShape recShapesI
+majorTypeShape resultShape resultTypeShape hxs hys hrargs houtEq houtTyEq
+hlastPair hpMajor hresultType htyMajor hvMajor halignedI hPiI`; substs
+collapse `xsI = majorX :: recXs`, `ysI = majorY :: recYs`, `rargsI =
+majorShape :: recShapes`, `outI = resultShape.app majorShape`, `outTyI =
+resultTypeShape.app majorShape`, and identify `ctorHead = ctor`
+(ADQ:3038-3048). Then:
+- `hctorClass : Params.classify ctor = some (.ctor
+  ctorShapes.reverse.length)` (ADQ:3049-3052)
+- `hmajorCtor := LR.DefEq.ctor'_inv hctorClass hpMajor hvMajor`
+  (ADQ:3053-3054): by SLR:11040-11047 this is
+  `LRS.IndTyHead Γ₀ D ∧ LRS.CtorDefEq Γ₀ (LR Γ₀) majorX majorY
+  (WShape.ctor ctor ctorShapes.reverse hwf)` where `D` is the last-Pi
+  domain (`hvMajor : (LR Γ₀).DefEq majorX majorY hlastPair.domain
+  majorShape majorTypeShape`, per field `majorRel` ADQ:1165). Note: the
+  free-closure `CtorDefEq`, **not** a native `CtorExact` leaf.
+- `hrecargsI : LRS.CtorArgsDefEq (LR Γ₀) recXs recYs recShapes :=
+  halignedI.args.tail` (ADQ:3055-3057).
+
+### Target of the sorry
+
+The `IotaLeafDefEq` conclusion (ADQ:1324-1326) after the substs. Modulo
+exact post-`subst` normal form (inferred, not elaborated — verify in
+goal view):
+
+```
+(LR Γ₀).DefEq
+  ((majorX :: recXs).foldr (fun a f => f.app a) (.const c ls))
+  ((majorY :: recYs).foldr (fun a f => f.app a) (.const c ls))
+  AI (resultShape.app majorShape) (resultTypeShape.app majorShape)
+```
+
+with `c = rec` derivable from `hmfI` (the analogous
+`iotaDefEq_of_ctorExactAt` consumers all state the head as
+`.const rec recLs`, e.g. ADQ:1983-1986). This matches the conclusion
+shape of `LRS.iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:2072-2077) at
+`recLs := ls`.
+
+## buildP status
+
+**`buildP` exists as a named hypothesis slot, not a definition.** It is
+the main callback of `LE_Interp.Witness.recNatRDeepSound`
+(SLR:8521-8548, binder at SLR:8523-8532):
+
+```
+buildP : ∀ (d : Nat) {ρ m M} (hM : LE_Interp.Witness ρ m M),
+  hM.RDeepChildren (fun hM' => P hM' ∧ hM'.RDeepChildren P ∧
+    LE_Interp.Witness.SoundRDeepAt P Γ₀ hM' d) →
+  (∀ d' < d, ∀ {ρ m M} (hM' : Witness ρ m M),
+    P hM' ∧ hM'.RDeepChildren P ∧ SoundRDeepAt P Γ₀ hM' d') →
+  P hM
+```
+
+Sibling slots: `buildC` in `recNatRDeepConsumer` (SLR:8553) and
+`recNatRDeepConsumerAt` (SLR:8592). The plans' phrase "the buildP
+algebra" (log line 295, completion plan line 649, roadmap line 776) means:
+*write the concrete instantiation of this slot* — i.e. choose the
+predicate `P` and prove the per-constructor cases.
+
+The evident candidate for `P` is **`LR.FixedHeadResult`** (ADQ:1331-1367):
+a Prop on one witness `hX : Witness ρ root X`, universally quantified
+inside over level `n`, context `Γ` (with a `Ctx.WF Γ` input, ADQ:1346),
+iota rule, and spine data; conclusion
+`(LR (n+1) Γ).DefEq (r.1.applyS recLs mx) (r.1.applyS recLs my) A out
+outTy` (ADQ:1366-1367). Already proved cases/transports:
+`mono` (ADQ:1369), `mono_l` (ADQ:1380), `bot` (ADQ:1391), `bvar`
+(ADQ:1408), `sort` (ADQ:1424). Its consumer chain is fully in place:
+`LRS.iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:2040-2088) takes
+`hP : ∀ (hr : R m M), LR.FixedHeadResult (hR hr)` and feeds
+`LRS.IotaRHSDefEq.of_nonbotWitnessResult` (ADQ:1635-1699, applied at
+ADQ:2081-2088), which selects the fixed-head witness *together with* its
+retained `P` via `LE_Interp.RHS.fixedLowerWitnessResult` (SLR:4507-4517),
+so lowering cannot reselect a different evaluator (the instance-#6
+repair).
+
+So the missing work is exactly: (i) `RDeepChildren.Laws FixedHeadResult`
+(two of five fields unproved — see gap G2), (ii) the `buildP` cases for
+witness constructors `app`, `lam`, `forallE`, `const` (the
+application-chain algebra proper, plus the "conversion/type-relation
+handoff and constant case" named at completion plan lines 653-656), and
+(iii) the assembly at the sorry (gaps G1, G4).
+
+## Machinery signatures (statement-level)
+
+Witness layer (SLR):
+- `LE_Interp.Witness` (3584-3605), **Type**-valued mirror of `LE_Interp`
+  (3550-3567). `const` case (3599-3605) stores `Params.env.constants c =
+  some ci`, `ls.length = ci.uvars`, root bound `m ≤ m'`, `m'.HasType a`,
+  the registered type's witness `Witness ρ a (mkInst ls ci.type)`, the
+  Prop evaluator `LE_Interp.Const c ls R [] m'`, and the proof-relevant
+  callback `∀ m e, R m e → Witness ρ m e`.
+- `Witness.mono` (3657) / `mono_l` (3672): lower root / grow valuation,
+  preserving the tree. `Witness.closed` (4957): change valuation entries
+  irrelevant to a `ClosedN M k` term. `Witness.recR` (3693): follow
+  exactly the stored R-edges.
+- `Witness.recDeep` (3748) / `recDeep₂` (3769): full structural recursion
+  (deep children); recDeep₂ keeps the first tree's IH polymorphic in the
+  second (term/type role swap).
+- `Witness.RDeepChildren P` (3799-3816): retained tree granting `P` (and
+  recursively `RDeepChildren P`) **only at abstract constant R-edges**
+  (const case, 3813-3816); ordinary children get only the recursive
+  structure. Closure lemmas: `map` 3838, `mono` 3858, `mono_l` 3898,
+  `closed` 5003, `lift'` 5114, `weak` 5172, `subst` 5215, `inst` 5277,
+  `forallE_inv'`/`lam_inv'` 6448/6490, `forallE_inst`/`lam_inst`
+  6552/6572.
+- `RDeepChildren.JoinLaws P` (3822-3834): `bot`, `mono`, `mono_l`,
+  `join` (join of two witnesses at `m₁.join m₂`). `RDeepChildren.Laws P`
+  (6814-6820) **extends JoinLaws with `closed`** — five fields total.
+- `RDeepChildren.compat_join` (5686+): from `JoinLaws P`, `ρ'.LE ρ`, and
+  two retained trees on the same `M`, produces `m₁.Compat m₂` and a
+  joined witness with a retained tree.
+- `recRDeep` (3942) / `recNatRDeep` (4020) / `recRDeep₂` (4044) /
+  `recNatRDeep₂` (4129): R-edge recursions; the `Nat` variants make
+  stratification depth the primary decrease, so conversion restarts on an
+  arbitrary witness only after `d' < d`.
+- `TypedRDeep P ρ m M A` (6614-6621): ∃ enlarged root `m'`, type shape
+  `a`, witnesses for `M` and `A`, `m ≤ m'`, `m'.HasType a`, both retained
+  trees. `TypeRDeep` (6624), `toType` (6632), `bot` (6640).
+- `TypedRDeep.app` (6654-6670): from `mono_l`+`closed` laws and two
+  callbacks (function typed at `.forallE A B`; instantiated result
+  `B.inst X` as a type), applies — "application itself introduces no new
+  semantic R edge".
+- `TypedRDeep.lam` (6895): laws + body callback (under `ρ.push x`) →
+  typed at `A.forallE B`. `TypedRDeep.forallE` (7169): laws + domain +
+  codomain callbacks → typed at `.sort (.imax u v)`.
+- `FitsRDeep P base Γ ρ` (8359-8366): valuation whose entries carry
+  witnesses + retained trees; `lookup` 8368, `push` 8386,
+  `Valuation.Fits.toFitsRDeepTrue` 8396.
+- `SoundRDeepAt P Γ₀ hM d` (8408-8415): ∀ `{Γ A core}`,
+  `HasTypeStratifiedS Γ M A core d → FitsRDeep P Γ₀ Γ ρ →
+  Valuation.Fits Γ₀ Γ ρ → TypedRDeep P ρ m M A`. (`Γ₀` here is an
+  auto-bound variable of each statement, chosen by the consumer.)
+- `soundRDeepRestart` (8421-8433): proves `SoundRDeepAt` below a depth
+  bound from `Laws P` + strictly-smaller restarts; syntax-directed cases
+  compiled through `TypedRDeep.app/lam/forallE`; the `defeq` case
+  (8503-8515) converts via `LE_Interp.sound` on the stratified equation.
+- `recNatRDeepSound` (8521-8548): `Laws P` + `buildP` ⊢ ∀ hM d,
+  `P hM ∧ hM.RDeepChildren P ∧ SoundRDeepAt P Γ₀ hM d`.
+- Fixed-head selection: `Lower R` (4447), `Lower.realizeWitness` (4466),
+  `RHS.fixedWitness` (4432), `RHS.fixedLowerWitness` (4476),
+  `RHS.fixedLowerWitnessResult(P, hR, hP, hmono)` (4490-4517) — selects
+  witness **and** its `P` from the same R-edge.
+- `LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a` (8666-8670): `left`, `right`,
+  `cross` edges at one relation/type/shapes. Ops: `diagonal` 8674,
+  `trans` 8680, `conv` 8689 (needs semantic `TyDefEq`), `mono_l` 8696,
+  `mono_r_1/2` 8705/8715, `whr` 8724 (all four endpoints in lockstep),
+  `LRS.DefEqRect.app` 10988 / `LR.DefEqRect.app` 11020.
+- `LRS.DefEq.app` (10962-10972): function edge at `LRS IH` level n+1 with
+  shape `.lam mf hmf : WShape (n+1)`, argument `IH.DefEq x y A₁ p b` at
+  level n, `p.HasType b`, raw `Γ ⊢ x ≡ y : A₁` ⊢ result `IH.DefEq (M.app
+  x) (N.app y) (A₂.inst x) (mf.app p) (tf.app p)` at level n. **Each app
+  step descends one level.**
+- `LR.DefEq.ctor'_inv` (11040-11047): classification + `HasType` +
+  `(LR Γ).DefEq M N A (.ctor' c fields) a` ⊢ `IndTyHead Γ A ∧
+  LRS.CtorDefEq Γ (LR Γ) M N (.ctor c fields hwf)` (free closure).
+- `LRS.CtorExact` (9561-9579): the native leaf — classification, level
+  lists equal (`ls = ls'`), head typings, two `SpineWF`s, `CtorArgsDefEq`
+  and both `CtorSpineDefEq`s.
+- `LRS.CaptureDefEqAligned IH m x y typeExpr` (11481-11487): ∃ shapes,
+  `m ≤ elemShape.T`, `elemShape.HasType typeShape`, `IH.TyDefEq typeExpr
+  typeExpr typeShape`, raw `Γ ⊢ x ≡ y : typeExpr`, `IH.DefEq x y typeExpr
+  elemShape typeShape`. `mono` 11504, `lift` 11511, `rebase` 11527.
+- `LE_Interp.RHS.ShapeSpine m2 head paths out` (3375-3383): per-path cons
+  `{n} {f : WShape (n+1)} {a : WShape n}`: `a.T ≤ m2 path → m ≤ (f.app
+  a).T → ShapeSpine m2 m paths out → ShapeSpine m2 f.T (path::paths) out`.
+  **The level `n` is existential and independent per step.**
+  `typedLowerHead` (3417): from per-path typed lower bounds + typed out,
+  a typed lower approximation of the head.
+- `LE_Interp.sound` (8353-8355): `IsDefEqStrong Γ M N A → Fits Γ₀ Γ ρ →
+  (LE_Interp ρ m M ↔ … N) ∧ (… → InterpTyped ρ m M A)`.
+
+SExpr layer:
+- `PathSpineWF Γ value type A paths B` (SE:1537-1550): dependent spine
+  over paths; `cons` consumes `.forallE (type path) A₂` and instantiates
+  at `value path`; **`conv` and `ret` embed raw `IsDefEq … (.sort u)`
+  edges** with no semantic counterpart.
+
+Adequacy layer (ADQ):
+- `LR.PatternLeafDefEq` (1276) / `LR.IotaLeafDefEq` (1302) — the leaf
+  contracts; `of_iota` (2178) bridges them.
+- `LR.FixedHeadResult` (1331-1367) — see above. Inputs at use-site: `Ctx.WF
+  Γ`, `X = mkInst recLs rule.df.rhs`, `head ≤ root`, strong self-typing
+  `IsDefEqStrong Γ X X (mkInst recLs rule.df.type)` (supplied by
+  `rule.rhsStrong`, used at ADQ:1575), `ShapeSpine`, typed lower head,
+  two `PathSpineWF`s at one shared `captureType`, per-path
+  `CaptureDefEqAligned` (rec at `LR (n+1) Γ`, ctor at `LR n Γ`,
+  ADQ:1358-1363), `out.HasType outTy`, `(LR (n+1) Γ).TyDefEq A A outTy`.
+- `LRS.IotaRHSDefEq` (1480-1508); `of_nonbot` (1519, discharges the bot
+  RHS and extracts head + `ShapeSpine` via `rule.rhsShapeSpine`,
+  supplies `rule.rhsStrong recLs`); `of_nonbotWitness` (1582);
+  `of_nonbotWitnessResult` (1635) — the P-preserving form; its capture
+  input shape (1669-1674) **matches FixedHeadResult's exactly** (levels
+  `LRS IH`/`IH` vs `LR (n+1)`/`LR n`).
+- `LRS.iotaDefEq_of_ctorExactAt` (1951-2031): pattern + matches + RHS +
+  **`CtorExact Γ₀ IH …`** + `PatternLeafSpine` + rec-head typing + out/A +
+  `rhsDefEq : ∀ rule, IotaRHSDefEq …` ⊢ the goal-shaped `DefEq`.
+- `LRS.iotaDefEq_of_ctorExactAt_fixedHead` (2040-2088): same but
+  discharges `rhsDefEq` from `hR` + `hP : ∀ hr, FixedHeadResult (hR hr)`;
+  demands **`hΓ : Ctx.WF Γ₀`** (2054) and `leaf : CtorExact Γ₀ (LR Γ₀) …`
+  (2064) — everything at the canonical relation.
+- `LR.iotaActions_of_exactEqAt` (used 1929, 2153) / `iotaDefEq_of_exactEqAt`
+  wrapper ending 1926-1939: the root-pair form taking `CtorArgsDefEq` for
+  both spines + weak-head reductions of both majors to their ctor spines.
+- `LR.constDefEq` (2193-2217): the structural constant evaluator; caller
+  supplies only `evalPat : PatternLeafDefEq`.
+- `LR.adequateApp` (2452-2471): the Adequate-level dependent-application
+  core (three lower callbacks: function, argument, instantiated result);
+  the template the buildP `app` case is meant to mirror
+  (completion plan 650-653).
+- `LR.Adequate.rect` (~935-945): packages adequacy output as a
+  `DefEqRect`; `LR.constLamDefEq` (1076-1137) consumes a rect-valued
+  `eval`.
+- `LR.JointBuilder` (717+), `foldRaw_of_jointBuilder` (751-756): the
+  typed chain-fold consumer — needs `B : JointBuilder` and `Ctx.WF Γ`,
+  where `B.rawTypeUniq`/`B.stratifiedInversion` (729-739) are derived
+  from **`LR.ContextualAdequacyAt 1`** (`B.first B.zero`) — i.e. from the
+  full adequacy theorem at levels 0/1.
+
+## Gap map
+
+Notation: (a) = directly in scope at the sorry, (b) = constructible via a
+named kernel-checked lemma, (c) = gap.
+
+Assembly route assumed (the only one whose consumers exist today): apply
+`LRS.iotaDefEq_of_ctorExactAt_fixedHead` (or its `exactEqAt` sibling)
+after decomposing `hmajorCtor.2`.
+
+| input | status |
+|---|---|
+| `hpat` | (a) `hpatI` ADQ:3028 |
+| `hmf`/`hma` | (a) `hmfI`/`hmaI` ADQ:3031-3032 |
+| `hrhs` at `Lower R` | (a) `hrhsI` ADQ:3028 — relation matches: the leaf is stated at `LE_Interp.Lower R` (ADQ:3021) and `of_nonbotWitnessResult` concludes at `Lower R` (ADQ:1679-1680) |
+| `hR : R → Witness` | (a) from the witness destructuring, ADQ:2891 (explicit-binder form; the consumer wants implicit — trivial eta wrapper) |
+| `hmono` for P | (b) `FixedHeadResult.mono` ADQ:1369; wired at ADQ:2083-2084 |
+| `hP : ∀ hr, FixedHeadResult (hR hr)` | (c) **G3** — this is buildP itself: `(recNatRDeepSound laws buildP (hR _ _ hr) 0).1` once laws+buildP exist |
+| `laws : RDeepChildren.Laws FixedHeadResult` | (c) **G2** — `join` and `closed` unproved (only `bot`/`mono`/`mono_l` exist, ADQ:1391/1369/1380; Laws needs five fields, SLR:6814+3822) |
+| `hΓ : Ctx.WF Γ₀` | (c) **G1** — see below |
+| `leaf : CtorExact Γ₀ (LR Γ₀) …` (or `exactEqAt`'s reductions + `CtorArgsDefEq` for the ctor spines) | (c) **G4** — `hmajorCtor.2` is the free-closure `CtorDefEq`; decomposition machinery is conditional on `JointBuilder` |
+| `hleaf : PatternLeafSpine` | (a) re-assemble the rcased fields of `hleafI` (all bound at ADQ:3033-3037) |
+| `hrecHead` | (a) `hheadI` after `c = rec` identification (via `hmfI`, cf. `varN_const_head` used at ADQ:3046-3048) |
+| `hout`, `hA` | (a) `houtI`, `hAI` |
+| capture relations for `IotaRHSDefEq` | produced internally by `iotaActions_of_exactEqAt` (ADQ:1927-1935) — needs G4's inputs first |
+
+### G1 — `Ctx.WF Γ₀` is not in scope (availability gap, low design risk)
+
+Required by `iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:2054) and by
+`FixedHeadResult` itself (ADQ:1346). Not available: `LR.adequacy`
+(ADQ:2856-2858) has no WF premise; `LR.SubstWF` (SLR:11797-11805) does
+not record target-context well-formedness; nothing in the const case
+introduces it. Downstream churn if threaded: `LR.adequacyAt` (ADQ:3547),
+`forallE_whRed_l` (ADQ:3573-3577), `sort_forallE_inv` (ADQ:3631), and
+`sort_inv` (ADQ:3696) all instantiate adequacy at an **arbitrary** Γ with
+no WF; `sort_invS` (ADQ:3698-3708) does have `hΓ : OnCtx …` to feed a WF
+premise, but the `forallE_inv` co-deliverables (ADQ:3605, 3631) would
+need new hypotheses or a move to their `_of_adequacy_collapsed` variants
+(ADQ:3583). Alternative: audit whether `FixedHeadResult` actually needs
+`Ctx.WF Γ` (it plausibly does, for stratified-typing restarts /
+weakening the closed head's typing into Γ) — if not, drop the field
+instead of threading it. Decide explicitly; do not discover this at
+`exact`-time.
+
+### G2 — `Laws FixedHeadResult`: `join` and `closed` unproved
+
+`recNatRDeepSound` needs all five fields (SLR:8521-8522, 6814-6820,
+3822-3834). `closed` should follow the `mono_l` pattern (FixedHeadResult
+never inspects ρ except through the witness; cf. ADQ:1380-1389 where the
+proof is transparent pass-through). `join` is the suspicious one: given
+`P H₁`, `P H₂` at `m₁.join m₂` on the same `M`, the ShapeSpine input
+arrives at `head ≤ m₁.join m₂` — the proof must route `head` through one
+of the joined bounds. Check whether `TShape.join`'s LE lemmas suffice
+(`head ≤ m₁.join m₂` does NOT give `head ≤ m₁` or `head ≤ m₂` in a join
+semilattice — it gives the reverse). If not directly provable, the
+`compat_join` machinery (SLR:5686) exists precisely because joins were
+needed at application nodes; `FixedHeadResult.join` may need the same
+`Compat`-based split of the ShapeSpine head. Budget real time here.
+
+### G3 — the buildP cases themselves (the planned work)
+
+Missing witness cases: `app`, `lam`, `forallE`, `const` (plus using
+`bot`/`bvar`/`sort` already proved). Per completion plan 649-656 the
+remaining content is "the conversion/type-relation handoff and constant
+case, then consuming the rectangle along the generated `ShapeSpine`".
+Available cores: `TypedRDeep.app/lam/forallE` (SLR:6654/6895/7169),
+`soundRDeepRestart` (8421), `LRS.DefEq.app` (10962), `DefEqRect` ops
+(8666-8737), `LR.adequateApp` as the shape template (ADQ:2452).
+Known sub-gap inside: converting TShape-level witness facts into
+level-indexed `(LR n Γ)` facts at the *consumer-demanded* `n` — the
+`toValTy` pattern (ADQ:2909-2915) handles existential levels via
+`le_n`/`le_a` + lift; the algebra must do this at every chain node whose
+`ShapeSpine` cons level is existential (SLR:3378-3380).
+
+### G4 — the major-side decomposition (highest #7 risk)
+
+`hmajorCtor.2` is a **free-closure** `LRS.CtorDefEq` at the canonical
+relation. Both existing leaf consumers need more: `…_of_ctorExactAt*`
+need a native `CtorExact` (ADQ:1972/2064); `…of_exactEqAt` needs
+weak-head reductions of both majors onto ctor spines plus root-to-root
+`CtorArgsDefEq` for the ctor fields (ADQ:2109-2114 in the `of_exact`
+wrapper). The chain-normalization layer (`CtorExact/CtorFrame/CtorLink/
+CtorChain/NativeAlgebra`, `CtorDefEq.toChain`, per completion plan
+430-446) exists, but the only typed fold consumer visible is
+`foldRaw_of_jointBuilder` (ADQ:751), which requires `B : LR.JointBuilder`
+— and `JointBuilder` is powered by `ContextualAdequacyAt 0/1`
+(ADQ:729-739), i.e. by the very theorem whose proof contains this sorry.
+**Inside `LR.adequacy`'s single derivation-induction there is no
+level-indexed fixpoint from which lower-level full adequacy (hence
+uniqueness, hence the typed chain fold) can be consumed.** The decided
+joint route (completion plan 403-412, 414-428) prescribes exactly that
+offset bootstrap ("uniqueness at n consumed by adequacy at n+2"), but
+`LR.adequacy` as written (2856) has not been restructured into it. So one
+of the following must be true before the leaf closes, and the worker
+should decide which *in the plan file first*:
+  1. The buildP/fixedHead route makes the typed chain fold unnecessary at
+     this site: a uniqueness-free *semantic* fold (per-link iota results
+     glued by `(LRS IH).trans` at the package-fixed type, midpoints via
+     `WHRedS.ctorSpine_determ`, frames folding completed results — plan
+     259-276, 440-446, 488-491) is written as a new `CtorChain` algebra
+     instance whose leaf handler is `iotaDefEq_of_ctorExactAt_fixedHead`.
+     Watch item: that handler is stated at `(LR Γ₀)` throughout; a link's
+     native relation must reach it only through the frame-transport of
+     the *completed* result, never by projecting the root prefix into the
+     native relation (the instance-#5 trap, plan 532-544).
+  2. Or `LR.adequacy` is restructured into the level fixpoint so a
+     `JointBuilder` (or `LimitedUniq` at the ctor-field level) is in
+     scope. That is a statement-level change to the main induction, not
+     leaf-local work — if the worker finds themselves needing
+     `ContextualAdequacyAt` inside the sorry, STOP (this is the two-strikes
+     rule's tripwire).
+  Note the composition-impossibility map (plan 342-356): lam-shaped
+  constructor fields cannot compose without uniqueness; `ctorShapes` here
+  come from a live `Matches` and are arbitrary. Route 1 works only if
+  the per-link/fold design genuinely avoids root-to-root *field*
+  composition (it composes link *conclusions*, not fields — that is the
+  design's whole point; verify this property survives contact with the
+  actual `CtorChain.Algebra` interface before writing Lean).
+
+### G5 — PathSpineWF's raw-only conv edges (latent)
+
+`PathSpineWF.conv`/`ret` (SE:1543-1550) inject raw `IsDefEq … (.sort u)`
+steps into the capture telescope with no semantic counterpart, while the
+chain algebra's `LRS.DefEq.app` needs semantic Pi data per step and
+`DefEqRect.conv` (SLR:8689) needs semantic `TyDefEq`. The intended
+source of the semantic telescope is the head's own type witness
+(`Witness.const` stores `hA : Witness ρ a (mkInst ls ci.type)`,
+SLR:3602) — i.e. the algebra derives its own telescope semantically and
+uses the supplied final `(LRS IH).TyDefEq A A outTy` (ADQ:1506) to land,
+never converting *along* a raw edge mid-chain. If a draft finds itself
+needing "raw defeq ⇒ semantic TyDefEq" mid-spine, that is adequacy-shaped
+and circular — same tripwire as G4.2.
+
+## Pre-mortem checklist (the six historical erasures, re-asked for buildP)
+
+1. **Erased midpoint/capture types (iotaSite/SpineDefEq era).** Q: does
+   any buildP-facing interface erase the types of intermediate chain
+   nodes? A: mostly repaired — both `PathSpineWF`s share **one**
+   `captureType` map (ADQ:1492-1498) and `CaptureDefEqAligned`
+   (SLR:11481) is stated *at* that map, so variable leaves are related at
+   the exact telescope domain ("the very domain used by both dependent
+   application spines", ADQ:1476-1477). Residual: the raw-only
+   `conv`/`ret` edges inside `PathSpineWF` (G5) are the one place a
+   midpoint typing is only raw. File:SE:1543-1550.
+
+2. **False assumption-free Retype (lambda observations).** Q: does the
+   buildP conversion handoff anywhere retype a lam-shaped observation
+   without the term-indexed callback? A: the new layer does not assume
+   `Retype`: `DefEqRect.conv` (SLR:8689) demands semantic `TyDefEq`;
+   `soundRDeepRestart`'s defeq case (SLR:8503-8515) converts via
+   `LE_Interp.sound` on the stratified equation itself; the lambda
+   boundary remains `LimitedUniq.LamRetype` (plan 509-519) and is NOT
+   consumed by the Witness layer. Risk shifts to G4's fold, not buildP.
+
+3. **Shallow children lost under symm/trans (RChildren era).** Q: does
+   `RDeepChildren` survive every transport buildP will perform? A: YES —
+   the closure family is comprehensive: `mono` SLR:3858, `mono_l` 3898,
+   `closed` 5003, `lift'` 5114, `weak` 5172, `subst` 5215, `inst` 5277,
+   binder inversions 6448/6490, instantiations 6552/6572, join via
+   `compat_join` 5686, plus `TypedRDeep.{mono,weak,out}` 6855/6862/6873.
+   This instance looks genuinely repaired.
+
+4. **Unary recursion couldn't cover two semantic inputs (recRDeep →
+   recRDeep₂ era).** Q: does the unary `recNatRDeepSound` reach the
+   type-side tree, and "does the hypothesis at an abstract constant edge
+   arrive at the level the root chain consumer folds at"? A: the
+   type-side tree is a *structural child* of `Witness.const` (SLR:3602)
+   retained by `RDeepChildren.const` (3813), and `TypedRDeep` carries
+   both trees (6617-6621) — so unary suffices structurally;
+   `recDeep₂`/`recNatRDeep₂` (3769/4129) remain available for role
+   swaps. Levels: the Witness layer is TShape-valued (level-free), and
+   `FixedHeadResult` is level-polymorphic *inside* the predicate
+   (ADQ:1333), so there is no fixed-level mismatch at R-edges **by
+   construction**; the level obligation moves entirely into the
+   TShape→`WShape n` conversion inside each buildP case (G3 sub-gap).
+   One verify-item: `FixedHeadResult` receives `IsDefEqStrong` self-typing
+   (ADQ:1349) but `SoundRDeepAt` consumes `HasTypeStratifiedS`
+   (SLR:8412); confirm the strong→stratified adapter exists at the depth
+   accounting `recNatRDeepSound` provides (`∀ d` is unbounded, so any
+   finite stratification depth is reachable — the question is only which
+   lemma produces the stratified derivation for `mkInst recLs
+   rule.df.rhs` in context Γ).
+
+5. **Native vs root relation (lift/unlift zigzag era).** Q: "does
+   DefEqRect's cross edge survive recursion into spine tails, or is it
+   rebuilt per node?" A: it survives compositionally —
+   `LRS.DefEqRect.app` (SLR:10988-11003) produces all three result edges
+   from the same argument observation and left-oriented codomain, and
+   `trans`/`whr`/`mono_*` (8680-8737) never mix endpoint witnesses; no
+   per-node rebuild. The eval site currently needs only `diagonal`
+   (ADQ:3067-3069) because both heads are the same constant. The
+   instance-#5 trap re-enters ONLY through G4's chain fold (a native
+   link's relation vs the canonical `(LR Γ₀)` of
+   `iotaDefEq_of_ctorExactAt_fixedHead`'s statement, ADQ:2064-2071) —
+   this is the single most likely home of failure mode #7.
+
+6. **Prop-valued provenance (LE_Interp proof irrelevance era).** Q: "is
+   anything in the chain Prop-valued where the consumer needs to case on
+   which branch produced it?" A: the fixed-head selection is clean —
+   `hR` is data in the witness (SLR:3604) and
+   `fixedLowerWitnessResult` (SLR:4490-4517) selects witness + retained
+   `P` from the *same* R-edge, with `hmono` covering the `Lower` root
+   drop (the instance-#6 repair, correctly threaded at ADQ:2081-2088).
+   Residual Prop-boundaries checked: `LE_Interp.Const`/`RHS`/`Matches`
+   are Props, but their consumers only *universally quantify* over rules
+   (`rhsDefEq : ∀ rule, …`, ADQ:1921-1922, 1980-1981) or destruct them
+   inside Prop goals — no consumer needs to remember *which* rule/pattern
+   fired across a proof-irrelevant boundary. One watch item: inside
+   buildP's `const` case, the witness's `hC : LE_Interp.Const c ls R []
+   m'` (SLR:3603) is Prop; if the app-chain algebra ever needs to case on
+   `hC`'s `.pat` vs `.lam` branch AND retain the choice into a
+   Type-valued construction, that is #6 all over again — the design says
+   it should not (the chain consumes only `hR`-selected witnesses and the
+   Prop-level `RHS`), but check the first draft for exactly this.
+
+## Probe file
+
+Ready-to-run axiom-closure probe. Place at repo root (e.g.
+`AxiomProbe.lean`) and run `lake env lean AxiomProbe.lean` (the flake dev
+shell provides lake; the Experimental import convention is confirmed by
+ADQ:1 and `Lean4Lean/Experimental/UniqueTyping.lean:1`).
+
+```lean
+import Lean4Lean.Experimental.ShapeLogRelAdequacy
+
+/-! Axiom-closure waypoints for the L4L-16 gate path.
+Expected clean baseline: [propext, Classical.choice, Quot.sound].
+`LR.adequacy` and everything through it (incl. `sort_invS`,
+`forallE_inv`, `sort_forallE_inv`) will show `sorryAx` until the
+iota leaf closes; the Witness-layer roots must NOT. -/
+
+#print axioms Lean4Lean.VEnv.IsDefEqU.sort_invS
+#print axioms Lean4Lean.SExpr.LR.adequacy
+#print axioms Lean4Lean.SExpr.LE_Interp.sound
+#print axioms Lean4Lean.SExpr.forallE_inv
+#print axioms Lean4Lean.SExpr.sort_forallE_inv
+-- Witness-layer roots the buildP step will lean on:
+#print axioms Lean4Lean.SExpr.LE_Interp.Witness.recNatRDeepSound
+#print axioms Lean4Lean.SExpr.LE_Interp.Witness.RDeepChildren.compat_join
+#print axioms Lean4Lean.SExpr.LE_Interp.Witness.TypedRDeep.lam
+#print axioms Lean4Lean.SExpr.LRS.IotaRHSDefEq.of_nonbotWitnessResult
+#print axioms Lean4Lean.SExpr.LRS.iotaDefEq_of_ctorExactAt_fixedHead
+```
+
+Caveat: `LE_Interp.sound` / `TypedRDeep.lam` etc. are `Lean4Lean.SExpr.*`
+because SLR/ADQ open `namespace Lean4Lean … namespace SExpr` (ADQ:4-6);
+`sort_invS` is declared `_root_.Lean4Lean.VEnv.IsDefEqU.sort_invS`
+(ADQ:3698). If a name fails to resolve after worker edits, re-grep — the
+declarations may have been renamed since this snapshot.
+
+### Measured (2026-08-14 ~07:15 EDT, all four Experimental files green)
+
+First live run (extended with `IsDefEqStrong.mkS` and three D0 fixture
+waypoints; run against the freshly built oleans):
+
+- `sort_invS`, `LR.adequacy`, `forallE_inv`, `sort_forallE_inv`:
+  `[propext, sorryAx, Classical.choice, Quot.sound]` — expected while the
+  leaf is open.
+- CLEAN at `[propext, Classical.choice, Quot.sound]`: `LE_Interp.sound`,
+  `IsDefEqStrong.mkS`, all five Witness-layer roots listed above, and the
+  D0 waypoints `ParamsD0.natParams` / `natTypeStrong` / `natIotaRule` —
+  the fixture inherits no admission so far.
+- `LR.iotaActions_of_exactEqAt` is CLEAN. The sorry-bearing
+  `LR.iotaActions_of_exact` (ADQ:2212 at probe time) has **zero
+  consumers**, and literal `WHRedS.defeq` no longer occurs in the
+  adequacy file. Modulo transitive consumption of the other three SExpr
+  admissions (all measured off-path at the 16B′ audit), the gate's sole
+  `sorryAx` source is now the leaf's own `sorry`: closing it cleans
+  `sort_invS` and both inversion co-deliverables simultaneously. The
+  orphaned `of_exact` wrapper is deletable at the next touch.
+
+## Review response: the shape-order mismatch (2026-08-14, sibling session)
+
+Re the reported gap — recursive fixed-head adequacy needs a typed lower
+observation (`headElem ≤ head`, supplied by `ShapeSpine.typedLowerHead`)
+*together with* a semantic interpretation of its type, while soundness
+types only an upper extension, and the two directions do not compose.
+
+1. **The rejection of the downward pullback is consistent with two
+   recorded corrections**, not just prudence: the `Shape.WF.plift`
+   refutation (no lift-shaped Pi below an arbitrary function shape) and
+   the `Retype` correction (lambda observations pin codomain validity to
+   the original Pi typing). Contravariant domains are the same wall in
+   both. Do not revisit it under stronger-sounding hypotheses; the
+   established principle is CARRY the evidence, never project it down.
+2. **The type's semantic witness may already exist in the retained tree
+   — check before constructing anything new.** `Witness.const` stores
+   `hA : Witness ρ a (mkInst ls ci.type)` (SLR:3602 at snapshot time):
+   the fixed head's *type* witness is a field of the very node the
+   fixed-head selection destructs. The synchronized package then needs
+   only to THREAD `hA` through the retained invariant and peel it per
+   application via the already-kernel-checked exact Pi inversion of the
+   retained-tree transport layer, feeding `TypedRDeep`'s dependent
+   application. If that holds, the repair is plumbing an existing field
+   through `FitsRDeep`'s motive, not new mathematics.
+3. **Two pre-flight checks on the widened invariant, per the
+   signature-first rule** (write the package as a Lean statement and
+   check every recursion case has its transport before proving):
+   (a) *binder cases* — the type-witness component must weaken through
+   `TypedRDeep.lam`/`forallE`; the transport layer's lift/weakening
+   coverage should supply this, verify it applies at the package's
+   indexing; (b) *depth/restart indexing* — the type's interpretation
+   recurses independently of the term's (this is WHY `Witness.recDeep₂`
+   is binary); the package must put the type witness in the second,
+   polymorphic slot of the binary principle rather than forcing it
+   through the unary `recNatRDeepSound` axis, and its restarts must obey
+   the same strict stratification-depth decrease.
+4. **Anchor at the lower observation from construction**, per the
+   NativeAlgebra order: build the package where `typedLowerHead` is
+   produced and transport completed results root-ward; never build at
+   `head` and project down.
+5. This is invariant-widening #8, but the first caught pre-proof; each
+   revision since the re-cut has strictly narrowed. If the widened
+   package hits a second wall (the likely spot: the compat-join case
+   failing to synchronize the type witness), the two-strikes rule
+   applies — state the obligation here before more Lean.
+
+### Frontier re-map after the pause (2026-08-14 ~16:30)
+
+Codex session PAUSED; tree stable. Snapshot for this section (verified
+unchanged across the analysis window): SLR mtime 2026-08-14 13:58:42,
+597560 B; ADQ mtime 2026-08-14 14:43:33, 214542 B. Sole sorry:
+**ADQ:4285**. Everything in the original body above refers to the old
+(2026-08-14 03:31) state; line numbers in THIS section are current.
+
+#### 1. The sorry site now
+
+The leaf was **extracted into a standalone theorem**:
+`LR.iotaWitnessStep : LR.IotaWitnessStep Γ₀` (ADQ:4255-4285), where
+`LR.IotaWitnessStep Γ₀` (ADQ:1505-1510) is
+`Ctx.WF Γ₀ → ∀ {ρ c ls R}, (∀ {m M}, R m M → Witness ρ m M) →
+LR.IotaLeafDefEq Γ₀ c ls (LE_Interp.Lower R)`. The proof intros
+`hΓ₀ ρ c ls R hR` (4256) and then replays the exact prelude of the old
+in-line block (intro 4257-4259 = old 3027-3029; `cases hmatchI` app case
+4260-4262; `rcases hleafI` 4263-4267; substs 4268-4277; `hctorClass`
+4278-4280; `hmajorCtor := LR.DefEq.ctor'_inv …` 4281; `hrecargsI` 4282-
+4284; sorry 4285). Target: unchanged from the original "Target of the
+sorry" section above (the `IotaLeafDefEq` conclusion, ADQ:1422-1424).
+
+Scope changes vs the old site: **`hΓ₀ : Ctx.WF Γ₀` is now bound**
+(4256) — old gap G1 is resolved at the leaf, and globally: `LR.adequacy`
+(4288-4293) and `LR.adequacyAt` (4298-4300) now take `hΓ₀`. But the
+scope is also LEANER: the old outer const-case data (`W : SubstWF`, the
+constant's type witness `hA'`, `hConst`, `hrec`, the `eval` app package)
+is gone — the step receives ONLY `hΓ₀` and the bare callback `hR`.
+
+**Is a lower-level adequacy hypothesis / JointBuilder bound at the
+sorry? NO.** The intended discipline is stated in the docstring
+(ADQ:4251-4254): the body "may consume only the well-founded fixed-head
+and predecessor-uniqueness packages, never the final polymorphic
+adequacy theorem" — but no such package appears in the theorem's
+hypotheses. The fixpoint restructure reached the *boundary*, not the
+sorry: `LR.adequacy_of_iotaWitnessStep` (ADQ:3572, ~680 lines) is the
+old induction parameterized by `iotaStep`, and it consumes the leaf
+**level-pinned** — `evalPat : LR.PatternLeafDefEqAt Γ₀ k c ls (Lower R)
+:= LR.PatternLeafDefEqAt.of_iota (iotaStep hΓ₀ hRI)` (ADQ:3743-3745),
+with `LR.constDefEq` restated to take the At-form (ADQ:2521). The
+level-indexed step interfaces exist but are **parked with zero
+consumers**: `IotaWitnessStepAt` (ADQ:1493), `IotaLeafDefEqAt`
+(ADQ:1427), `PatternLeafDefEqAt` (ADQ:1456). No level-indexed
+`adequacy_of_iotaWitnessStepAt` exists yet.
+
+#### 2. What codex built (the synchronized-package layer)
+
+The proposed "synchronized package" repair **largely exists**:
+
+- `LR.SelfAdequateAt Γ₀ hX depth` (ADQ:3145-3154): for all `n`, `mx bx :
+  WShape n`, `Δ`, `mx.T ≤ root` (**typed lower observation**),
+  `HasTypeStratifiedS Δ X B core depth`, `mx.HasType bx`, and
+  **`Witness ρ bx.T B` (semantic type witness) as an input** —
+  concludes `LR.Adequate Γ₀ Δ ρ X X B mx bx`. Private exact-root worker
+  `SelfAdequateExactAt` (3157); public downward closure is by
+  `hX.mono hroot` on the witness (ADQ:3467-3469), never by pulling
+  `HasType` back — consistent with the review response's point 1.
+- `LR.RetainedResultAt Γ₀ hX depth` (ADQ:3169-3175) =
+  `(SelfAdequateAt ∧ FixedHeadResultAt) ∧ RDeepChildren (True) ∧
+  SoundRDeepAt (True)` — the full retained invariant.
+- **Proved**: `selfAdequateExactAtStep` (ADQ:3200-3455) — every
+  `HasTypeStratifiedS` case of self-adequacy EXCEPT const (delegated to
+  a contract), given `inv : JointStratifiedInversion` + `hΓ₀`; its app
+  case (3247+) uses `lower`-restarts as the three adequateApp callbacks.
+  `selfAdequateAtStep` (3456-3469). `retainedResultAt_of_steps`
+  (ADQ:3488-3523): the complete well-founded plumbing via
+  `recNatRDeepConsumerAt` (SLR:8811) with retained-tree predicate
+  `T := fun _ => True` and `Laws.true` (ADQ:3519-3521) — **this
+  resolves old gap G2**: no `join`/`closed` laws for `FixedHeadResult`
+  are needed; the consumer/tree separation eliminates them.
+  `fixedHeadResult_of_steps` (ADQ:3527-3536). The conversion algebra
+  `LR.adequateDefeqSelf_of_stratifiedInversion` (ADQ:3071+, given inv)
+  and `LR.TyDefEq.of_defeq_of_stratifiedInversion` (ADQ:813) — the
+  "conversion/type-relation handoff" named in the old plan is proved,
+  conditional on `inv`.
+- `LR.FixedHeadResult` **restated** (ADQ:1515-1560): now `Γ₀`-explicit
+  and quantified over `LR.SubstWF Γ₀ σ σ' Δ ρ` (1517-1518) instead of
+  taking `Ctx.WF Γ`; `PathSpineWF`s at Γ₀ (1539-1542). Depth-indexed
+  `LR.FixedHeadResultAt` (ADQ:1562-1600) adds the input
+  **`HasTypeStratifiedS Δ X (mkInst recLs rule.df.type) true depth`**
+  (1582) — the stratified certificate the chain algebra needs to invoke
+  `SelfAdequateAt`; adapters `FixedHeadResult.at` (1604),
+  `of_forall_at` (1615, uses `IsDefEqStrong.stratify` 1621),
+  `FixedHeadResultAt.mono` (1625). Surviving case lemmas: `mono` 1636,
+  `bot` 1647, `bvar` 1664, `sort` 1680 (old `mono_l` dropped — no
+  longer needed by the new plumbing).
+- Leaf consumers restated: `iotaDefEq_of_ctorExactAt` (ADQ:2211, now
+  takes `hΓ`), `iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:2358-2408, now
+  takes `W : SubstWF Γ₀ σ σ' Δ ρ` (2373) + `hΓ : Ctx.WF Γ₀` (2374) +
+  `hP` at the new `FixedHeadResult Γ₀` (2383); still `leaf : CtorExact
+  Γ₀ (LR Γ₀) …` (2384)); `of_nonbotWitnessResult` at ADQ:1891.
+- New SLR plumbing (+~14KB): `WShapeFun.AppLEData`/`appLEData`
+  (SLR:6516/6526) and `WShape.HasDomData`/`HasDom.data`
+  (SLR:6559/6565) — noncomputable Type-valued extractors of lower-shape
+  application/domain data (the peeling plumbing for the chain);
+  `LE_Interp.RHS.realizeWitness*` (SLR:4384-4408).
+- **Unchanged**: `LE_Interp.Witness` (SLR:3584) — the `const`
+  constructor (3599-3605) still has exactly seven fields (hreg, hlen,
+  hle, hty, hA, hC, hR); the `ihA/ihR` seen at SLR:3640 are induction-
+  hypothesis names inside `witnessNonempty`'s proof, not constructor
+  fields. `FitsRDeep` (now SLR:8578) is the same inductive; its `cons`
+  carries a per-BINDING type witness (8583-8584) as before. The
+  head-type witness of the synchronized package lives in
+  `SelfAdequateAt`'s `hB` input, not in `FitsRDeep`.
+
+#### 3. Gap map at ADQ:4285 (current)
+
+(a) in scope: `hΓ₀` (new), `hR`, `hpatI hmatchI hrhsI`, all
+`PatternLeafSpine` fields, `hctorClass`, `hmajorCtor` (IndTyHead ∧
+free-closure `CtorDefEq`), `hrecargsI` — as before.
+
+(b) constructible via named lemmas GIVEN the three missing inputs
+below: `hP hr := (fixedHeadResult_of_steps inv hΓ₀ constStep fixedStep
+(hR hr))` (ADQ:3527); the RHS discharge is fully wired inside
+`iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:2398-2408).
+
+(c) gaps, ordered by depth:
+
+- **C1 — `inv : JointStratifiedInversion`, non-circularly.** Gates
+  everything: `retainedResultAt_of_steps`, `fixedHeadResult_of_steps`,
+  `adequateDefeqSelf…`, and any `foldRaw_of_jointBuilder` use. The only
+  constructors are `JointStratifiedInversion.of_adequacy`
+  (ADQ:435, needs `ContextualAdequacyAt 1`) and
+  `of_adequacy_and_typeUniq` (ADQ:4417) — both need the theorem being
+  proved. No prover of `JointBuilder.zero`/`first` (ADQ:718-719)
+  exists. The designed escape (JointBuilder docstring ADQ:700-716:
+  "level-zero adequacy is built first; a specialized base argument
+  builds level-one adequacy without predecessor uniqueness") requires
+  the level ladder: a level-indexed `adequacy_of_iotaWitnessStepAt`
+  consuming `IotaWitnessStepAt` (the consumption at ADQ:3743-3745 is
+  already level-pinned, so this refactor is prepared), plus direct
+  proofs of the level-0/1 leaf instances. None of this is wired yet.
+  **If the worker tries to prove `LR.iotaWitnessStep` as stated
+  (polymorphic, no package hypotheses), C1 is unreachable — the
+  statement must gain hypotheses or the ladder must land first.**
+- **C2 — `constStep : LR.SelfAdequateConstStep Γ₀`** (ADQ:3178-3195),
+  unproven, no prover theorem exists. Content: constant self-adequacy
+  from the evaluator semantics + `RetainedResultAt` restarts; the
+  template is the main induction's const case (ADQ:~3600-3757).
+- **C3 — `fixedStep : LR.FixedHeadStep Γ₀`** (ADQ:3474-3483), unproven
+  — the application-chain algebra proper, and the home of the
+  **residual shape-order blocker**. Status of the blocker: NARROWED but
+  live. To invoke `SelfAdequateAt` at the fixed head, the algebra must
+  supply (i) `mx.T ≤ root` — available via `typedLowerHead` (SLR:3417)
+  ✓; (ii) the stratified typing — now an input of `FixedHeadResultAt`
+  (ADQ:1582) ✓ (added in the final pre-pause hours); (iii)
+  `mx.HasType bx` — from `typedLowerHead`'s TShape pair, plumbing ✓;
+  (iv) **`Witness ρ bx.T B` — the registered type interpreted at the
+  LOWER type observation — still has no visible producer.** Soundness
+  (`LE_Interp.sound`, `TypedRDeep`) types only upper extensions;
+  downward pullback stays invalid at function shapes. The intended
+  construction (per review-response point 4 and the new
+  `AppLEData`/`HasDomData` extractors) is to BUILD the lower Pi-shaped
+  type witness along the registered telescope from capture-type
+  witnesses + the out-type witness — that constructor does not exist
+  yet. This is the one place the blocker's mathematics remains.
+- **C4 — major decomposition** (old G4, unchanged): `hmajorCtor.2` is
+  the free-closure `CtorDefEq`; consumers need `CtorExact` (ADQ:2384)
+  or exactEq reductions + ctor-field `CtorArgsDefEq`. The typed fold
+  `foldRaw_of_jointBuilder` (ADQ:751) needs a full `JointBuilder` —
+  same circularity family as C1. A uniqueness-free semantic fold
+  instance for THIS consumer is still unwritten.
+- **C5 — SubstWF availability at the leaf (wiring check, flagged
+  uncertain).** The restated consumers demand `W : SubstWF Γ₀ σ σ' Δ ρ`
+  at the leaf's *arbitrary* ρ, but `SubstWF` (SLR:12143-12151) only
+  constructs `.id` at `ρ = .nil` plus pushes — no instance for
+  arbitrary ρ. Plausible intended resolution: the fixed head is CLOSED
+  (`rule.rhsClosed`), so `Witness.closedAt` (SLR:5168) transports its
+  witness to `.nil` and `W := SubstWF.id` suffices; but then the
+  capture relations (at the ambient ρ) and the head relations (at
+  `.nil`) must be recombined. Verify this valuation split *on paper*
+  before writing the fixedStep — it smells like erasure-instance
+  material if done implicitly.
+
+#### 4. Bottom line
+
+The pause state is a genuine narrowing: G1 resolved (hΓ₀ threaded), G2
+dissolved (consumer/tree separation — no Laws needed), the synchronized
+package designed, stated, and proved for every non-const structural
+case, and the well-founded plumbing finished. What remains is exactly
+three unproven inputs (C1 ladder/base-levels, C2 const producer, C3
+chain algebra with the narrowed type-witness-at-lower-shape
+construction) plus the unchanged major-decomposition assembly (C4) and
+one valuation-wiring check (C5). The sorry itself is now a pure
+assembly point: nothing in its local scope blocks it except the absence
+of those inputs.
+
+## Decision synthesis — the resumption work order (2026-08-14 ~16:45)
+
+Product of three parallel design investigations against the paused
+tree (frontier re-map above; a construction-probe pass; a ladder/
+alternative adversarial pass). All referenced probe files elaborate
+green under `lake env lean` and are preserved in `plans/probes/`
+(gitignored). Statements marked PROVED are fully term-proved there and
+can be lifted into the codebase directly.
+
+**Architectural decision (supersedes the level-ladder reading of route
+2): index the joint fixpoint by stratified typing DEPTH, not shape
+level.** The shape-level `JointBuilder` tower (`zero`/`first`/succ) is
+structurally unrealizable: `LE_Interp.app` stores function shapes at a
+free constructor level and `adequateApp` runs at interpretation-derived
+max-levels, so full adequacy at any fixed level requires leaf instances
+at unboundedly many levels — every rung is same-index circular
+(unbounded-ascent argument; cruxes in `probeC-ladder-crux.lean`, all
+seven elaborate). `LiftEquiv` cannot rescue it (iff only at
+literally-lifted observations). The predecessor-package alternative is
+also dead: the lower head's type lives at a level ≥ the leaf's own, and
+adequacy consumes interpretations rather than manufacturing `Witness`es.
+Depth, by contrast, genuinely decreases (`HasTypeStratifiedS.forallE_inv`)
+and is already the machinery's measure (Nat-first restarts,
+`lower : ∀ d' < depth+1`). The level tower may survive only as a final
+public assembly facade.
+
+**Work order, in dependency order:**
+
+1. **Depth-indexed bootstrap** (unblocks everything inv-shaped: C1, the
+   conversion cases, C4's callbacks). Retire the level-polymorphic
+   `iotaWitnessStep` obligation in favor of the depth-indexed form
+   (`IotaWitnessStepAt`, parked at ADQ:1493); restate the ~400-line
+   bootstrap (ADQ:59-440) depth-bounded (`AdequacyAtDepth` +
+   `JointStratifiedInversionAt D` from depth-≤D adequacy — statements
+   elaborate in probeC). Mechanical but the largest single chunk.
+   STANDING TRIPWIRE: audit every leaf-internal inversion consumption
+   for strictly-smaller depth; one same-depth consumption re-imports
+   the G4 circularity.
+2. **N1 — `typedLowerHeadLE`** (the C3(iv) shape half). Strengthen
+   `typedLowerHead` so `elemTy ≤ a` by the spine recursion over the
+   single-layer peel, which is PROVED (`peelLayerProved`,
+   probeB-2). The witness half is `Witness.mono` (root-lowering is
+   legitimate — no pullback). Remaining content: the induction's
+   level-lifting bookkeeping and re-anchoring the tail at
+   `tyFun.app argCap`. C5's type-witness half is dissolved: registered
+   types are closed (`closedAt` + `henv.closedC`), so the witness
+   component is valuation-free.
+3. **N2 — the capture-domain link. The ONE surviving design decision;
+   state it in this file before writing Lean (two-strikes rule).** Each
+   capture shape needs a typed upper bound in the *peeled registered
+   domain*; element-side singletons need fire points ≥ the spine arg
+   while `HasDom.data` supplies typed args ≤ it, so the bound must come
+   from peeling the OUTER recursor-constant's `hA` along the pattern
+   `Matches` — i.e. an invariant-widening of `FixedHeadResultAt`'s
+   `hcap` input (or a joint two-telescope recursion). The context-free
+   form (probeB-1 S6) is stated but likely unprovable as written; do
+   not attempt it.
+4. **C2 `SelfAdequateConstStep`** — assembles from 1-3's outputs
+   (probeB-1 S2 confirms the exact `SelfAdequateAt` invocation fits).
+5. **C4** — one `RawAlgebra` consumer instance; its `RawTypeUniq` and
+   two root callbacks all derive from step 1's inversion package
+   (`foldRaw_of_jointBuilder` body pattern, ADQ:756-762). Needs no
+   `JointBuilder`.
+6. `FixedHeadStep`, the leaf fold, then the endpoint measurement
+   (probe: `plans/probes/AxiomProbe.lean`; expect `sort_invS` clean and
+   record `forallE_inv`/`sort_forallE_inv` clean simultaneously).
+
+**Verified non-risks** (do not re-litigate): unary recursion axis
+suffices (widened component threads through `recNatRDeepConsumerAt` —
+`widenedThreading` PROVED; `recDeep₂` has zero adequacy-file
+consumers); compat-join demands nothing of the widened consumer
+(`Laws.true` separation, and `compat_join` would synchronize anyway);
+restarts cover fresh-depth type witnesses (`soundRDeepRestart`).
+
+**Risk ranking:** (1) N2's design — the shape-order wall's surviving
+kernel, now one input of one structure; (2) step 1's rung audit; (3)
+N1's literal-Pi requirement across `PathSpineWF`'s raw conv/ret edges
+(G5) — the peel needs `mkInst recLs rule.df.type` to stay a literal Pi
+telescope along capture paths.
+
+## N2 decision — retain one ordered term/type telescope (2026-08-14)
+
+**Decision: take the joint two-telescope route, not a pointwise widening of
+`CaptureDefEqAligned`.**  A standalone field for each path cannot certify
+that its alleged domain is the domain selected by the *same* registered-type
+observation after all earlier dependent applications.  It would also leave
+`PathSpineWF.conv`/`.ret` free to switch the syntax telescope without moving
+the semantic type witness.  Both are erasure #7 in a new wrapper.
+
+The producer will therefore recurse in `rule.capturePaths` order while the
+outer recursor evaluator and its registered-type evidence are still in
+scope.  One layer retains, at a common shape level:
+
+- the RHS-spine argument `aSp` and a capture cap `argCap` with
+  `aSp ≤ argCap`;
+- `argCap.HasType tyDom`, where `tyDom` is the domain of the current peeled
+  registered-type observation;
+- the recursive result below `g.app aSp`, re-anchored at
+  `tyFun.app argCap` on the type side.
+
+The consumer for exactly this layer is now kernel-checked as
+`LE_Interp.RHS.ShapeSpine.peelTypedLayer` in `ShapeLogRel.lean`.  Its proof
+needs no ambient upper function or downward typing transport: the three
+fields above plus the recursive term/type bounds construct the singleton
+lambda/Pi layer and prove both lower inequalities.
+
+The completed ordered certificate must expose the fixed-head consumer's
+actual endpoint, not merely another synthetic typing pair:
+
+```text
+∃ headElem headTy,
+  headElem ≤ head ∧ headElem.HasType headTy ∧
+  Nonempty (LE_Interp.Witness ρ headTy
+    (SExpr.mkInst recLs rule.df.type))
+```
+
+`FixedHeadResultAt` will consume that synchronized endpoint.  The current
+context-free `typedLowerHead` input remains useful only as the shape fallback
+and must not be used to manufacture the final witness.  The ordered producer
+belongs at the outer `constDefEq`/`Matches` materialization boundary, where
+the recursor's type evidence and the accumulated semantic-to-logical
+argument caps coexist; the leaf-local `hcap` map is already too late.
+
+Two invariants are part of this decision:
+
+1. A raw `PathSpineWF.conv`/`.ret` edge may be crossed only by the strictly
+   smaller typing-depth inversion package.  A same-depth conversion call is
+   the standing circularity tripwire.
+2. Valuation changes are explicit.  Closed registered roots may use
+   `Witness.closedAt`, but an ambient-`ρ` capture certificate is never
+   silently combined with a `.nil` head witness; the joint producer performs
+   and records the transport before the leaf boundary.
+
+## Post-resumption rung audit (2026-08-14)
+
+The first implementation pass validated the shape half of the review and
+found two additional interface mismatches in the proposed depth bootstrap.
+They must be resolved before C2/C4 are implemented against that bootstrap.
+
+1. **The bounded semantic result is path-valued, not ordinary inversion.**
+   `AdequacyAtDepth` directly proves bounded sort observation and Pi
+   observation with `TypeDefEqPath` domain/codomain outputs.  It does *not*
+   directly prove `JointStratifiedInversionAt`: a `TypeDefEqPath` erases the
+   stratification depths of its intermediate endpoints, so the existing
+   global path-collapse proof cannot be reused inside one bounded rung.
+   Probe C only established that the stronger statement elaborated; its body
+   was `sorry`.  The kernel-checked result is now named
+   `JointStratifiedPathInversionAt.of_adequacyAtDepth`.  Ordinary inversion is
+   recovered only after the final, depth-polymorphic adequacy theorem exists.
+
+2. **`IotaWitnessStepAt` is shape-level indexed.**  Its parameter pins the
+   `WShape` level of `IotaLeafDefEqAt`; it carries no typing-depth certificate.
+   It therefore cannot be the depth rung named in work-order item 1 without a
+   new contract.
+
+There is also a statement-level tripwire on the current
+`AdequacyAtDepth`: a stratification of only the left endpoint does not bound
+the strong equality derivation paired with it.  In `symm` the recursive
+derivation needs the opposite endpoint; in `trans` it needs the intermediate
+endpoint; and in `const` the registered RHS premise can have a deeper typing
+derivation than the constant's declared type.  Consequently the current
+definition is a valid observation interface but is too broad, by itself, to
+be the induction unit for the main adequacy proof.  The repaired rung must
+retain a coherent depth certificate for the strong derivation (or an
+equivalent proof-relevant transport invariant), not merely an arbitrary
+`HasTypeStratifiedS` proof for its left term.
+
+One dependency previously routed through ordinary bounded inversion has
+already been removed safely.  The `HasTypeStratifiedS.defeq` branch of
+retained self-adequacy now consumes a `SelfAdequateDefeqStepAt` callback.
+Its well-founded implementation calls `LR.adequateDefeq` with heterogeneous
+adequacy at the strictly smaller certificate depth; the compatibility
+implementation still accepts completed global stratified inversion.  Both
+paths are kernel-checked.  This isolates the remaining rung decision to the
+constant/fixed-head producers instead of letting it leak through the whole
+syntax-directed algebra.
+
+The next bootstrap edit must therefore choose and state the coherent
+derivation-depth certificate first.  Until then, do not implement C2/C4 by
+assuming either `JointStratifiedInversionAt.of_adequacyAtDepth` or a
+depth-indexed meaning for the existing `IotaWitnessStepAt`; neither theorem
+exists.
+
+## Ordered-telescope implementation status (2026-08-14)
+
+The consumer half of the N2 decision is now complete and kernel-checked in
+`ShapeLogRel.lean`:
+
+- `ShapeSpine.TypedTelescope` retains the exact capture order and threads the
+  same `argCap` through both the term spine and the dependent codomain
+  `tyFun.app argCap`;
+- `TypedTelescope.lowerHead` folds that certificate through
+  `peelTypedLayer` into `TypedLowerHead`; and
+- `TypedLowerHead.withWitness` exposes the fixed-head endpoint selected
+  above:
+
+  ```text
+  ∃ headElem headTy,
+    headElem ≤ head ∧ headElem.HasType headTy ∧
+    Nonempty (LE_Interp.Witness ρ headTy A)
+  ```
+
+This closes the ordered *consumer/certificate* problem, not its producer.
+The remaining architecture gate is the recursion contract.  The current
+Nat-first `R`-deep recursor supplies semantic-child consumer results only at
+the parent term's exact typing depth.  That contract is not evaluator
+coherent: a shallow constant typing derivation can unfold to a registered RHS
+whose syntax-directed typing proof is deeper.  Conversely, restarting only
+from the semantic witness loses the retained provenance needed after
+conversion.  C2/C4 must therefore wait for a recursion certificate that
+supports evaluator unfolding and retained conversion together; the new
+ordered telescope must not be wired to the known-invalid same-depth callback.
+
+### Recursion-contract probe
+
+A focused elaboration probe of `selfAdequateExactAtStep` confirms exactly
+where the information is lost.  The `HasTypeStratifiedS` induction
+hypotheses are generalized over the semantic witnesses, but invoking one at
+a selected function/argument/result witness requires
+`RDeepChildren (RetainedResultAt ... d)` for that witness.  The parent
+package retains consumer results only at abstract `R` edges, and semantic
+typing was intentionally separated with tree predicate `T := fun _ => True`.
+Consequently the `TypedRDeep` enlargement/join can retain an exact evaluator
+tree, but not the consumer result needed when the enlarged witness becomes a
+syntax-induction subject.
+
+The two tempting interface changes are both invalid in isolation:
+
+1. Keeping Nat first and asking an `R` child only at the parent's depth fails
+   when the reached registered RHS has a deeper syntax-directed typing.
+2. Keeping semantic descent first and asking every `R` child at all depths
+   still cannot restart on an unrelated converted/enlarged witness: supplying
+   both freedoms abstractly admits the cycle “raise depth along `R`, then
+   lower depth and restart at the parent witness.”
+
+The repaired certificate must therefore be *provenance-sensitive*.  It must
+show that each witness selected by application/conversion is obtained from
+the retained subject/type trees by the existing root, valuation, closed,
+instantiation, or compatible-join transports, and it must carry the consumer
+result across exactly those transports.  Equivalently, a replacement may
+use a genuinely derived environment/evaluator bound, but a bare global Nat
+assumption would be a new oracle and is not admissible.  This is now the sole
+architecture decision before C2/C4; more wrappers around
+`recNatRDeepConsumerAt` do not address it.
+
+### Provenance-closure checkpoint
+
+The first half of that replacement is now kernel-checked.  The semantic
+module has a free `Witness.TransportClosure P` containing only the transports
+that preserve an already-selected evaluator tree (`bot`, root lowering,
+valuation growth, compatible join, and closed-term valuation change), with
+an automatic `RDeepChildren.Laws` instance.  `Witness.recRDeepTransport`
+therefore follows genuine `R` edges before inserting `.base`; it does not
+grant a consumer result to a witness merely because that witness has the
+same public indices.
+
+On the adequacy side, `LR.CoherentRetainedResult` packages self-adequacy and
+the fixed-head result at every stratification depth, and
+`coherentRetainedResult_of_step` closes that package from one semantic-first
+algebra.  A direct induction,
+`Witness.typedRDeep_of_stratified`, also kernel-checks all syntax-directed
+typing constructors without a Nat restart.  Binder enlargement is discharged
+by semantic typing of the domain; the only abstract input left by this
+theorem is proof-relevant transport across the displayed-type equality in a
+`HasTypeStratifiedS.defeq` node (`DefeqRDeepTransport`).
+
+The mixed eliminator is now explicit as
+`Witness.recRDeepNatTransport`.  It performs structural `R` descent before
+the Nat induction, gives genuine `R` children every Nat index, and permits a
+strictly-smaller Nat restart only after the caller supplies the restarted
+witness's complete `RDeepChildren (TransportClosure ...)` certificate.  The
+adequacy specialization is `LR.CoherentRetainedNatStep`, closed by
+`coherentRetainedResult_of_natStep`; its two consumer obligations are split
+as `CoherentSelfStep` and `CoherentFixedHeadStep` and reassembled by
+`CoherentRetainedNatStep.of_steps`.  All of these declarations and the full
+adequacy module build with the sole pre-existing iota admission unchanged.
+
+That callback is an *isolation boundary*, not yet an admissible assumption.
+In particular, its fully generic statement for an arbitrary tree predicate
+`P` is stronger than the final construction may use.  The reverse direction
+of a registered definition/action can build a constant witness whose selected
+`R` edge is the current RHS witness.  To prove `RDeepChildren P` for that new
+constant, a generic transport would need `P` of the current witness, exactly
+the result under construction.  Adding such a case to `TransportClosure`
+would reintroduce the cycle in proof-relevant form.
+
+Consequently the next interface must retain the *actual strong equality (or
+endpoint stratification) derivation* at conversion.  Congruence, beta/eta,
+root/valuation transport, instantiation, and compatible join can preserve the
+tree structurally; a reverse registered step must instead consume its genuine
+smaller RHS-typing/equality hypothesis.  Do not implement
+`DefeqRDeepTransport (TransportClosure CoherentRetainedResult)` as a global
+oracle, and do not add an unconstrained “conversion” constructor to
+`TransportClosure`.
+
+### Depth-local endpoint-rebuild refinement
+
+The next implementation probe found a smaller sufficient interface than a
+constructor-by-constructor interpreter for `IsDefEqStrong`, while preserving
+the checkpoint's prohibition on a global conversion oracle.
+
+The recursive-edge evidence is now split into two layers:
+
+```text
+NatSeed Q d h       := (∀ k, Q h k) ∨ Q h d
+NatProvenance Q d h := TransportClosure (NatSeed Q d) h
+```
+
+`Witness.recRDeepNatProvenance` exposes `RDeepChildren (NatSeed Q d)` to the
+consumer algebra and injects genuine outer-recursion children on the left.
+A tree rebuilt after a strict Nat decrease may inject an edge only on the
+right, at that exact smaller depth.  `NatProvenance` is introduced later,
+inside retained semantic typing, where root/valuation/closed/join transports
+must be recorded.  The adequacy specializations are respectively
+`LR.CoherentSeedAt` and `LR.CoherentProvenanceAt`; the outer self/fixed-head
+consumers see only the inspectable seed, never the free transport closure.
+
+The key new operation is `Witness.RDeepChildren.of_step`.  Given an exact
+converted endpoint witness, it rebuilds that witness's evaluator tree
+structurally.  Only after a real `R` child's own tree has been rebuilt may a
+caller attach a result for that child.  Therefore, inside an outer rung at
+depth `D`, the already-complete callback for `d < D` can safely attach
+`CoherentRetainedAt ... d` local seeds throughout a freshly selected endpoint
+tree.  Reverse definition folding is then harmless: if the new constant's
+`R` edge points back to the old RHS witness, that edge receives only the
+already-complete result at `d`, never the all-depth result at `D` currently
+under construction.
+
+The following bridge is kernel-checked:
+
+- `LR.CoherentSeedAt.rebuild` constructs the inspectable exact evaluator
+  tree used at the consumer boundary;
+- `LR.CoherentProvenanceAt.rebuild` performs the guarded tree rebuild;
+- `LR.CoherentRetainedAt.restart` packages the strictly-smaller-depth
+  restart;
+- `LR.coherentDefeqRDeepTransportAt` selects the converted endpoint by
+  semantic soundness and rebuilds its tree from the local seed constructor;
+  and
+- `Witness.typedRDeep_of_stratifiedLocal` instantiates the retained semantic
+  typing proof with that conversion bridge.
+
+This supersedes only the claim that the equality derivation itself must be
+interpreted constructor by constructor.  The safety conclusion above is
+unchanged: generic `DefeqRDeepTransport P` remains only an isolation boundary,
+and no unconstrained conversion constructor belongs in `TransportClosure`.
+
+### Exact iota-consumer revalidation
+
+The first direct consumer of the refined seed interface is now
+kernel-checked as `LRS.iotaDefEq_of_ctorExactAt_coherent`.  It preserves the
+`NatSeed` injection through root lowering and splits at the selected fixed
+RHS head:
+
+- an `.inl` genuine evaluator child chooses the native depth returned by
+  `rule.rhsStrong recLs |>.stratify` and consumes its all-depth fixed-head
+  result there;
+- an `.inr` rebuilt child consumes only its exact local result and therefore
+  requires the registered RHS typing raised to that same local depth.
+
+This confirms that the provenance repair is sufficient on the consumer side
+and makes the remaining producer obligation exact.  The direct coherent
+constant/fixed-head algebra must justify the local RHS depth budget at the
+actual rebuilt endpoint.
+
+The follow-up implementation now packages that obligation as
+`LR.CoherentRhsSeedAt Γ₀ Δ depth hRhs rhsType`.  Its two constructors are
+deliberately asymmetric:
+
+- a genuine evaluator child carries `CoherentRetainedResult` and therefore
+  needs no selected depth certificate; and
+- a rebuilt child carries both `CoherentRetainedAt ... depth` and the exact
+  `HasTypeStratifiedS Δ rhs rhsType true depth` certificate.
+
+`LRS.iotaDefEq_of_ctorExactAt_coherent` consumes this coupled package at the
+*same proof-relevant `R` edge*.  The generic lower-witness eliminator hides
+the endpoint index, so the implementation guards its predicate by the
+explicit equality to `mkInst recLs rule.df.rhs` and discharges that equality
+before opening the package.  This prevents a proof-irrelevant re-selection
+from pairing one edge's retained result with another edge's typing budget.
+The focused adequacy target builds with this interface.
+
+The stale proof-independent route has also been removed: `RetainedResultAt`,
+`FixedHeadStep`, `CoherentFixedHeadStep.of_step`,
+`retainedResultAt_of_steps`, and `fixedHeadResult_of_steps` no longer exist.
+The syntax-directed self algebra now receives `CoherentSeedAt` trees and
+returns coherent retained results directly.
+
+What remains is therefore a producer theorem, not another consumer adapter:
+at the actual constant evaluator edge it must construct
+`CoherentRhsSeedAt`.  A bare local `CoherentSeedAt` is insufficient in the
+constant case, because a shallow constant typing may expose a registered RHS
+whose native stratification is deeper.  No all-depth result, generic
+conversion transport, proof-independent pairing, or same-depth assumption
+may be manufactured to discharge that local branch.  The next producer
+contract must retain the derivation that justifies the local RHS certificate
+(or retain an equivalent exact ordered type-telescope witness) at the point
+where that edge is created.
+
+### Focused-edge correction and producer boundary
+
+Rechecking the exact iota consumer against the live conversion code found one
+stale conclusion in the depth-local endpoint-rebuild checkpoint above.
+`LR.coherentDefeqRDeepTransportAt` does rebuild a selected endpoint tree, but
+it ignores the endpoint stratifications supplied by the equality derivation
+and reselects the public endpoint witness through semantic soundness.  It
+therefore does **not** preserve the proof-relevant evaluator edge required by
+`CoherentRhsSeedAt`, and it must not be used as the final conversion producer.
+The checkpoint remains useful for the guarded rebuild operation itself; its
+claim that the conversion bridge is complete is superseded here.
+
+The proof-relevant RHS half of the replacement is now kernel-checked:
+
+- `LE_Interp.Witness.appNVarsFocused` peels the exact application witness,
+  joins repeated capture occurrences, and retains the literal fixed-head
+  sub-witness;
+- `Pattern.IotaRule.focusedShapeSpine` specializes that extraction to the
+  registered iota tower; and
+- `Pattern.IotaRule.focusedRHS` reconstructs the registered RHS using only
+  root lowerings of that retained head witness.
+
+Thus the next producer contract is deliberately narrower than another
+conversion oracle.  While the reverse registered action still has both the
+exact endpoint derivation and the exact RHS witness in scope, it must produce
+one package containing:
+
+1. the retained fixed-head sub-witness and its ordered semantic capture
+   spine;
+2. the ordered registered-type telescope for the same capture caps; and
+3. either the genuine evaluator-child result or the exact local
+   `HasTypeStratifiedS` derivation for the focused RHS edge.
+
+Only after constructing that package may the reverse action rebuild the
+constant with `appsRealizeFocused`.  Extending `LR.constDefEq` alone cannot
+repair the loss: the current reverse action uses proof-independent
+`RHS.of_applyS` followed by ordinary `apps_realize`, so it can discard the
+selected edge before `constDefEq` is entered.  The implementation order is
+therefore fixed: retain the ordered type derivation at action materialization,
+rebuild the focused constant witness, then thread the resulting
+`CoherentRhsSeedAt` through the constant/fixed-head algebra.
+
+### Packed-telescope consumer checkpoint (2026-08-15)
+
+The consumer side of that order is now stronger than the earlier
+`TypedTelescope`/`Captures` sketch.  The active tree contains
+`ShapeSpine.TypedTelescope.WithCaptures`, a single inductive certificate that
+owns the semantic spine, the registered-type telescope, and the exact aligned
+capture payload at every layer.  Its fold
+`TypedTelescope.fixedHeadShapeChain` returns the lower term, its lower
+registered-type observation, the type bound, and the logical application
+chain from the same constructor choices.
+
+On the adequacy side, `LR.FixedHeadTelescope.withWitnessAndChain` lowers the
+registered-type witness and returns it together with that same chain.
+`LR.FixedHeadTelescope.toApplicationWith` then zips the chain with the
+concrete `PathSpineWF`, invoking semantic conversion only for actual
+`conv`/`ret`/domain edges and invoking head self-validity only for the literal
+lower endpoint just selected.  Both experimental semantic modules build with
+these declarations, and no new admission was introduced.
+
+This closes the downstream erasure risk: once a producer supplies
+`WithCaptures`, no later theorem can independently reselect the lower head,
+its registered type, or its capture chain.  It does **not** yet construct that
+certificate.  The live `StrongSoundEq.ofAction` reverse direction still calls
+proof-independent `RHS.of_applyS`, `build_spine`, and `apps_realize`; by then
+the exact RHS witness used by the endpoint derivation may already have been
+replaced.  The next producer edit must therefore live at (or immediately
+inside) that reverse-action/conversion boundary and return the packed
+telescope before rebuilding through `appsRealizeFocused`.
+
+### Producer-placement correction and first depth peel (2026-08-15)
+
+The last sentence above is too literal about what can be returned at the
+reverse-action boundary.  `LR.FixedHeadTelescope` is instantiated with
+`CaptureDefEqAligned.AtShapes`; it depends on the later adequacy-side
+`mx`/`my` endpoints, shared `captureType`, substitution, and logical relation.
+None of those values exists inside `StrongSoundEq.ofAction`.  Constructing
+that exact package there is therefore not merely inconvenient but
+ill-typed.  The semantic conversion boundary must instead retain the exact
+focused RHS witness and its derivation-aware registered-head typing.  The
+final `WithCaptures` fusion belongs at the fixed-head adequacy boundary,
+where that semantic certificate and the logical capture payload first
+coexist.
+
+The first producer-side depth fact is now kernel-checked in `SExpr.lean`:
+
+- `HasTypeStratifiedS.app_inv` removes outer displayed-type conversions and
+  exposes all five premises of the literal application derivation at
+  `depth - 1`;
+- `foldl_app_head` iterates that inversion through a concrete left-associated
+  application tower;
+- `foldl_app_head_of_ne_nil` proves that a nonempty tower's literal head is
+  typed at a strictly smaller depth; and
+- `Pattern.IotaRule.rhsHeadStratified{,_of_nonempty}` specializes the result
+  to the exact fixed RHS selected by `rule.rhsApply`.
+
+This removes the former uncertainty about whether focused application
+inversion supplies a genuine well-founded decrease.  The remaining type
+alignment is now explicit: the native head derivation returned by the peel
+has an existential `HeadType`, while `CoherentRhsSeedAt` requires the
+registered `mkInst recLs rule.df.type`.  The next producer theorem must align
+those two at the same smaller derivation depth using the concrete registered
+capture spine (and only its actual conversion edges).  Once that alignment
+is retained, `appsRealizeFocused` can rebuild the outer constant with edges
+generated from the exact head witness; the adequacy-side fold can then fuse
+the aligned captures into `FixedHeadTelescope` without reselecting the head
+or its type.
+
+### Exact head handoff correction (2026-08-15)
+
+The final paragraph above overstates the need to identify the peeled native
+`HeadType` with the registered rule type.  The head-term half is
+heterogeneous: `AdequacyAtDepth` is indexed by the exact registered
+`HasTypeStratifiedS` derivation but accepts the semantic witness for the
+displayed registered type independently.  Consequently the proof does not
+need raw type uniqueness, an equality cast, or a general conversion oracle
+to obtain the head term relation.
+
+The consumer now makes the two genuinely distinct obligations explicit.
+`LR.AdequacyAtDepth.closedHeadSelf` returns both the head term relation and
+semantic validity of the exact registered head type at the same lower type
+observation.  The former comes from heterogeneous term adequacy.  The latter
+uses `hstrat.isType` and adequacy at the preceding type rung.  Moreover,
+`LR.FixedHeadApplication` retains the exact head term relation instead of
+discarding it and asking a later consumer to run self-adequacy again.  The
+focused adequacy module kernel-checks with this term-and-type handoff and no
+new admission.
+
+The remaining producer obligation is therefore narrower and more concrete:
+construct `ShapeSpine.TypedTelescope.WithCaptures` (or an equivalent single
+proof-relevant package) whose lower head type, ordered capture layers, and
+output observation are all selected from one recursion.  An independently
+chosen lower type witness is insufficient, even when it is propositionally
+compatible, because downward projection through a function observation is
+not generally available.  This ordered packed producer--not equality of the
+native and registered syntax types--is now the live architecture gate.
+
+### Focused reverse-action certificate (2026-08-15)
+
+The first producer-side handoff at the corrected boundary is now
+kernel-checked.  `Pattern.IotaRule.FocusedActionPreimage` is a data-bearing
+certificate selected from the exact interpreted RHS witness.  It retains:
+
+- the literal fixed-head sub-witness and ordered semantic capture spine;
+- the matched constant/argument prefix reconstructed by `build_spine`; and
+- the exact `Const` derivation whose abstract evaluator relation is
+  `headWitness.LowerEdge`.
+
+`Pattern.IotaRule.focusedActionPreimage` constructs the certificate without
+calling `RHS.of_applyS`, and `FocusedActionPreimage.witness` realizes the
+matched redex with `Witness.appsRealizeFocused` at a caller-supplied typed
+observation.  Thus reverse action no longer needs to erase and then reselect
+the fixed RHS edge.
+
+This checkpoint intentionally stops before claiming the complete producer.
+The caller must still obtain that typed RHS observation from the retained
+endpoint stratification without losing its evaluator tree, and the
+adequacy-side boundary must still fuse the retained semantic spine with the
+ordered logical captures into `WithCaptures`.  Those are now separate,
+explicit obligations; neither can be replaced by public semantic soundness
+or an independently selected type witness.
+
+### Derivation-aware reverse-action transport (2026-08-15)
+
+The focused certificate is now wired into retained semantic conversion.
+`LR.focusedExtraReverseRDeepAt` dispatches the pattern carried by an
+`IsDefEqStrong.extra` node: zero-arity definition patterns keep the guarded
+local endpoint rebuild, while generated iota patterns use the exact
+`FocusedActionPreimage` path.  The internal focused evaluator is generalized
+over the action's declared type; the public displayed-type conversion remains
+the `Sort u` specialization.
+
+`LR.coherentDefeqRDeepPairAt` interprets the strong equality
+bidirectionally.  It swaps continuations under `symm`, composes them under
+`trans`, and focuses precisely the reverse branch of `extra`.  Consequently
+an iota action nested under equality symmetry or composition can no longer be
+hidden by one proof-independent soundness call.  The live
+`coherentDefeqRDeepTransportAt` now consumes this derivation-aware path, and
+the focused adequacy module kernel-checks with the sole pre-existing iota
+admission unchanged.
+
+This closes evaluator-edge preservation through conversion, but not the
+coupled producer required by the coherent iota consumer.  The rebuilt
+constant's `LowerEdge` still receives `CoherentProvenanceAt`; it does not yet
+receive the exact registered-head `HasTypeStratifiedS` certificate needed to
+form `CoherentRhsSeedAt` in the local branch.  That certificate must be
+constructed where the retained semantic spine and the concrete ordered
+`PathSpineWF`/capture relations coexist, then packed with `WithCaptures`.
+
+### Producer split after live-signature audit (2026-08-15)
+
+The last sentence above places one half of the remaining producer too late.
+The logical `WithCaptures` package still belongs at the fixed-head adequacy
+boundary: its `mx`/`my`, substitution, logical relation, and aligned capture
+payload do not exist during semantic conversion.  The exact local registered
+RHS typing certificate cannot wait for that boundary, however.
+
+The live signatures make the loss explicit:
+
+- `StratifiedDefeqRDeepTransport` supplies both endpoint
+  `HasTypeStratifiedS` derivations at the conversion node;
+- `coherentDefeqRDeepTransportAt` currently binds them as `_hA`/`_hB` and
+  returns only `RDeepChildren (CoherentProvenanceAt ...)`;
+- the focused `extra` branch preserves `headWitness.LowerEdge`, but
+  `CoherentProvenanceAt.local` stores only `CoherentRetainedAt`; and
+- `CoherentFixedHeadStep` later receives neither the discarded endpoint
+  derivation nor an action-indexed replacement for it.
+
+Consequently generic provenance plus the later ordered capture telescope is
+not by itself an implementable producer for `CoherentRhsSeedAt`.  Public
+semantic soundness would merely reselect the endpoint, and
+`rule.rhsStrong.stratify` chooses an unrelated native depth that need not fit
+the local guarded-restart depth.
+
+The producer must be split across the two boundaries:
+
+1. **At focused reverse conversion**, retain a semantic-only certificate
+   tied to the literal `LowerEdge`: the exact fixed-head witness and semantic
+   spine already carried by `FocusedActionPreimage`, plus the derivation/depth
+   evidence needed to justify the local registered RHS typing.  This package
+   must survive the result type of derivation-aware conversion; constructing
+   it transiently and returning plain `CoherentProvenanceAt` still erases it.
+2. **At the fixed-head adequacy boundary**, combine that retained semantic
+   and typing certificate with the concrete `PathSpineWF` and aligned logical
+   captures to construct `TypedTelescope.WithCaptures`, then consume it via
+   `FixedHeadTelescope.toApplicationWithAdequacyAtDepth`.
+
+This correction does not reopen the rejected raw type-equality route and does
+not move logical captures into conversion.  It only identifies the minimum
+action-indexed fact that must cross conversion before the later synchronized
+fusion can be sound.
+
+### Post-implementation preservation audit (2026-08-15)
+
+The first enriched-provenance implementation kernel-checks, but auditing its
+actual flow through `coherentDefeqRDeepPairAt` found a second erasure point.
+The recursive interpreter does visit an `extra` nested below `symm` or
+`trans`, and `rebuildFocused` tags the literal lower edges of the reconstructed
+constant.  That is not yet sufficient to say the certificate survives the
+whole equality:
+
+- each non-`extra` leg is implemented by
+  `coherentDefeqRDeepFallbackPairAt`;
+- that fallback deliberately ignores the incoming `RDeepChildren` tree,
+  selects a fresh endpoint through public semantic soundness, and rebuilds a
+  new local tree; and
+- consequently, in a composite equality, any fallback leg *after* the
+  focused leg erases the focused seed before the final endpoint is returned.
+
+Thus the earlier statement that a nested action “can no longer be hidden” is
+only a traversal claim.  It is not yet an end-to-end preservation theorem.
+The next contract must make the suffix explicit: either interpret the
+remaining equality constructors proof-relevantly while retaining the same
+focused evaluator relation, or return a conversion-path certificate whose
+consumer can replay those exact endpoint choices.  Adding more data solely
+to `FocusedRhsOriginAt`, while leaving the suffix fallback proof-independent,
+cannot close the producer.
+
+This also sharpens the role of the retained typing fields already added to
+`FocusedActionPreimage`.  They are necessary at the action boundary, but they
+must travel with the proof-relevant evaluator edge through the *entire*
+conversion path.  A transient focused node followed by a plain local rebuild
+is observationally indistinguishable from the erasing implementation that
+the producer split was meant to replace.
+
+### Closed-valuation leaf consumer and consumption-tower survey (2026-08-15, session-C subagent)
+
+Baseline at resumption: green, zero errors, exactly one `declaration uses
+sorry` at the `LR.iotaWitnessStep` leaf (statement now ADQ:6406, sorry
+ADQ:6436 after this session's insertions).  Source and olean were
+consistent at 06:24; a fresh full elaboration reconfirmed the state before
+any edit.
+
+**The preservation question of the previous section is already answered in
+the tree.**  Between writing "Post-implementation preservation audit" and
+pausing, the previous writer landed the replayable conversion-path
+certificate (candidate 2): `LR.FocusedRhsTraceAt` (ADQ:3882),
+`LR.FocusedRhsTraceBundleAt` (ADQ:3896), the `carried`/`replayed`
+constructors of `LR.CoherentSemanticSeedAt` (ADQ:3907), and
+`LR.CoherentProvenanceAt.rebuildTracingFocused` (ADQ:4220), which is now
+wired into both legs of `LR.coherentDefeqRDeepFallbackPairAt` (ADQ:4845).
+The fallback no longer discards the incoming tree's focused history: every
+rebuilt recursive edge carries the complete source trace bundle, replayable
+at matching registered-head syntax.  I did not re-litigate that design;
+this session's work is downstream of it.
+
+**Two consumption walls found between the conversion layer and the sorry,
+one repaired, one mapped:**
+
+1. *SubstWF/valuation coupling (repaired this session).*
+   `LR.FixedHeadResult`/`FixedHeadResultAt` are consumed through
+   `LR.SubstWF Γ₀ σ σ' Δ ρ` at the witness's own valuation, and the only
+   closed `SubstWF` constructor is `.id` at `Valuation.nil`
+   (SLR:14222).  The `IotaWitnessStep` leaf receives an arbitrary caller
+   valuation with no fits certificate, so the existing consumers
+   `iotaDefEq_of_ctorExactAt_fixedHead` and `_coherent` are unusable at
+   that leaf as stated — their `W` pins ρ.  Repair, kernel-checked and
+   landed: the registered RHS is closed, so the selected head witness is
+   transported to `Valuation.nil` at the same root shape by
+   `Witness.closedAt` (whole-tree transport, not endpoint reselection)
+   and consumed at `SubstWF.id` with `Γ := Γ₀` instances of
+   `rule.rhsStrong`.  This is the C5-dissolution argument
+   ("registered types are closed") applied to the witness side, and it
+   retains everything: spine, typed lower head, raw telescopes, and
+   aligned captures were already valuation-free.
+
+2. *The chain wall (mapped; NOT repaired; do not attempt leaf-locally).*
+   At the sorry, the major arrives as `hmajorCtor.2 :
+   LRS.CtorDefEq Γ₀ (LR Γ₀) majorX majorY (ctor' ...)` via
+   `LR.DefEq.ctor'_inv` — the free closure, not a single `CtorExact`.
+   Consuming it requires the normalized chain fold
+   (`CtorDefEq.toChain` + rectangles; the exact-link rectangle
+   `LRS.iotaDefEqRect_of_ctorExactAt` ADQ:2748 was prepared for exactly
+   this and `LogRel.DefEqRect.trans` composes shared-middle rectangles).
+   The blocker: interior chain vertices must be retyped at the recursor
+   domain, and every chain consumer that does this
+   (`CtorChain.rawDefEqAt`, `foldRaw`, `foldRaw_of_stratifiedInversion`)
+   takes raw type uniqueness / `JointStratifiedInversion` — which is only
+   constructible FROM adequacy (`of_adequacy` needs
+   `ContextualAdequacyAt 1`, ADQ:582), i.e., not at the bare leaf (G4).
+   A uniq-free fold was examined and fails structurally: `NativeAlgebra.trans`
+   threads no typing for the shared middle vertex, and deriving it from
+   link raw equalities reintroduces pairwise type uniqueness.  Conclusion:
+   the leaf sorry is discharge-LAST.  It needs inversion at strictly
+   smaller stratified depth, i.e., the depth-indexed adequacy rungs
+   (`LR.AdequacyAtDepth` producers) of work-order step 1, which remain
+   unlanded — nothing in the file yet produces `AdequacyAtDepth`, it is
+   only consumed (ADQ:31/1834/1946/5355).
+
+**Landed this session (kernel-checked, elaboration green, zero errors, the
+sole sorry unchanged at ADQ:6436):**
+
+- `LRS.iotaDefEq_of_ctorExactAt_closedFixedHead` (ADQ:2871).  The
+  ρ-decoupled exact-link consumer: same interface as `_fixedHead` but the
+  fixed-head oracle is `∀ hX : Witness Valuation.nil root X,
+  FixedHeadResult Γ₀ hX`, consumed after `closedAt` transport at
+  `SubstWF.id`.  Proof goes through `IotaRHSDefEq.of_nonbotWitness` (no
+  P-threading needed — the oracle is global, so no `mono`-commutation
+  obligation arises).
+- `LRS.iotaDefEq_of_ctorExactAt_natStep` (ADQ:4561).  The formal residual-
+  gap statement: the exact iota link follows from
+  `LR.CoherentRetainedNatStep Γ₀` alone, via
+  `coherentRetainedResult_of_natStep` + `CoherentRetainedResult.fixedHead`
+  + the closed consumer above.
+
+**The remaining tower, in dependency order (all names live in the file):**
+
+1. Depth bootstrap (work-order step 1, still the critical path): produce
+   `LR.AdequacyAtDepth Γ₀ d` / `ContextualAdequacyAtDepth d` by strong Nat
+   induction.  Both walls above point here: it feeds
+   `SelfAdequateDefeqStepAt.of_lowerAdequacy` (ADQ:5355) and depth-bounded
+   inversion (`JointStratifiedPathInversionAt.of_adequacyAtDepth`,
+   ADQ:563) for the chain fold's vertex retyping.
+2. `LR.SelfAdequateConstStep Γ₀` (ADQ:5298, unproved): the constant case
+   remake consuming `children`/`lower` instead of derivation induction; its
+   internal iota leaf should use the coherent consumer with seeds drawn
+   from the const witness's own `RDeepChildren` tree — NOT the global
+   `iotaWitnessStep`.
+3. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4503, unproved): the
+   `WithCaptures` fusion.  Its missing ingredient is the ordered
+   spine→`FixedHeadTelescope` producer (N1/N2 peel); only the `nil`/`cons`
+   constructors exist today (ADQ:1700/1715).  `SelfAdequateAt` (not global
+   `AdequacyAtDepth`) supplies the head validity inside the algebra via
+   `of_fixedHeadTelescope`/`toApplicationWith`.
+4. Assembly: `CoherentRetainedNatStep.of_steps` (ADQ:4516) then the chain
+   fold at the leaf feeding `iotaDefEq_of_ctorExactAt_natStep` per exact
+   link, with vertex retyping through the depth-bounded inversion of 1.
+
+**Design note recorded for the depth-local variant:** a depth-local closed
+consumer (analogue of `_coherent` at `Valuation.nil`) would need either a
+witness-term commutation lemma `closedAt`-vs-`mono` (to thread a
+per-witness seed through `of_nonbotWitnessResult`'s `hmono`), or seeds
+stated directly at `Valuation.nil` witnesses.  Deliberately not attempted
+this session (two-strikes discipline; the global-oracle form needed no such
+commutation).  Whoever writes `SelfAdequateConstStep` should prefer stating
+its rule-indexed seeds at nil witnesses from the start.
+
+### Depth bootstrap landed conditionally; N1 peel core ported (2026-08-15, session-C subagent 2)
+
+Baseline at resumption: green, zero errors, exactly one `declaration uses
+sorry` at the `LR.iotaWitnessStep` leaf.  Reconfirmed by full elaboration
+before edits; the identical inventory holds after every edit below (final
+log `elab2`: sole sorry warning at ADQ:6540:8, the same leaf statement,
+moved only by insertions).
+
+**Landed (all kernel-checked; no new sorries):**
+
+- `LR.IotaWitnessStepAtDepth Γ₀ depth` (ADQ:1701) and
+  `LR.ContextualIotaWitnessStepAtDepth depth` (ADQ:1709): the
+  depth-indexed joint-leaf obligation.  At rung `depth` the leaf
+  producer receives `∀ d' < depth, LR.ContextualAdequacyAtDepth d'` —
+  the raw strict-predecessor family, deliberately unprocessed — and
+  returns the ordinary level-polymorphic `IotaWitnessStep Γ₀`.
+- `JointStratifiedPathInversionAt.of_predecessorAdequacy` (ADQ:584):
+  the `<`-shaped bridge — a successor rung's strict family below
+  `depth + 1` is exactly the `≤ depth` family `of_adequacyAtDepth`
+  (ADQ:563) consumes, so a leaf producer at rung `d + 1` can assemble
+  bounded path inversion at depth `d` with no same-depth adequacy
+  consumption.
+- `LR.contextualAdequacyAtDepth_of_iotaSteps` (ADQ:6503): THE
+  BOOTSTRAP.  `(∀ d, ContextualIotaWitnessStepAtDepth d) → ∀ d,
+  ContextualAdequacyAtDepth d` by `Nat.strongRecOn`.  The step case
+  hands the untouched strong-induction hypothesis to `steps d` and runs
+  `adequacy_of_iotaWitnessStep` (ADQ:5808) with the resulting leaf.  No
+  separate base case: at `d = 0` the family quantifier is vacuous and
+  the step receives an empty package (honesty note below).
+- `LR.contextualAdequacyAt_of_adequacyAtDepth` (ADQ:6519) and the
+  composition `LR.contextualAdequacyAt_of_iotaSteps` (ADQ:6530): the
+  full depth tower subsumes every level-indexed contextual package via
+  `IsDefEqStrong.stratify`.  The level tower is now formally a facade
+  over the depth fixpoint, closing that architectural decision of the
+  2026-08-14 synthesis.
+- `WShape.HasTypeLam.peelLayer` (ADQ:1743): verbatim port of the PROVED
+  probe `probeB.peelLayerProved` (plans/probes/probeB-2.lean), placed
+  with the `FixedHeadTelescope` producers it will feed.  `hgle`/`hty`
+  stay in the signature (unused by the layer algebra, two lint warnings
+  accepted) to pin the spine recursion's interface.  `widenedThreading`
+  was NOT ported: it commits the `LowerSyncAt` widened-component
+  interface, which belongs to the N2 capture-domain decision this file
+  requires stating in prose before Lean.
+
+**Why the design respects the standing constraints.**  Depth-indexed,
+never level-indexed: the fixpoint index is stratified typing depth; the
+leaf stays level-polymorphic exactly as `IotaWitnessStep` is today.
+G4: the bootstrap constructs no predecessor package — no inversion, no
+uniqueness, nothing derived from the IH inside the induction — it
+forwards the raw rung family through the step interface, whose
+docstring names the two sanctioned consumers
+(`of_predecessorAdequacy`, `SelfAdequateDefeqStepAt.of_lowerAdequacy`,
+ADQ:5440).  The global sorried `iotaWitnessStep` is never referenced.
+Erasure: the step receives the full contextual family, not a
+projection.
+
+**Honesty note — where the remaining depth content lives.**  Producing
+`AdequacyAtDepth Γ₀ d` cannot use the rung's own certificate: the
+derivation induction is depth-blind (the ADQ:25 docstring caveat is
+real — `trans`/`symm`/evaluator descent reach subderivations the
+left-endpoint certificate does not bound, and depth-0 certificates
+exist via `sort'`, so even the base rung covers arbitrary derivations
+with sort-left endpoints).  The bootstrap therefore ignores `hstrat`
+(it is a hypothesis of the PRODUCED statement, for consumers), and
+`IotaWitnessStepAtDepth 0` degenerates to the bare global leaf.  The
+depth restriction that will make the step family dischargeable must
+come from the leaf's OWN certificates — the registered-rule stratified
+typings (`rhsStratified`/`headStratified`, SLR:9280-9283) that bound
+the chain fold's vertex retyping — not from the adequacy root.  That is
+the rung audit of the 2026-08-14 synthesis (risk #2), now localized to
+one named obligation instead of an amorphous circularity.
+
+**Remaining tower (updated difficulty against the previous survey):**
+
+1. `LR.SelfAdequateConstStep Γ₀` (ADQ:5383, unproved; hard, design
+   partly pre-committed): state its rule-indexed seeds at
+   `Valuation.nil` witnesses from the start (previous section's design
+   note).  Its conversion callback is now one hypothesis away:
+   `of_lowerAdequacy` consumes exactly the bootstrap's rungs.
+2. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4588, unproved; medium once N2 is
+   stated): ordered spine→`FixedHeadTelescope` producer.  Per-layer
+   core is now in-file (`peelLayer`); N2 (capture-domain link) remains
+   the one open design decision and must be stated in this document
+   before Lean.
+3. Assembly `CoherentRetainedNatStep.of_steps` (ADQ:4601), then the
+   chain fold at the leaf feeding `iotaDefEq_of_ctorExactAt_natStep`
+   (ADQ:4646) per exact link, vertex retyping through
+   `of_predecessorAdequacy` at the rule certificates' depths.  If those
+   depths stay strictly below the rung index, the step family
+   discharges per-rung and the bootstrap closes unconditionally; if a
+   same-rung consumption appears, that is the G4 tripwire firing — stop
+   and escalate to a design session, do not patch.
+
+Consumers already prepared (`closedHeadSelf` ADQ:1919,
+`toApplicationWithAdequacyAtDepth` ADQ:2009, `of_lowerAdequacy`
+ADQ:5440, bounded inversion ADQ:563/584) are all reachable from the
+single hypothesis family `∀ d, LR.ContextualIotaWitnessStepAtDepth d`.
+
+— session-C subagent 2
+
+### SelfAdequateConstStep interface decision — seeds pinned by the ambient SubstWF, not restated at nil (2026-08-15, session-C subagent 3)
+
+Written before the Lean, per the two-strikes prose-first rule, because it
+deviates in letter (not in force) from the standing note "state the
+rule-indexed seeds at `Valuation.nil` witnesses from the start."
+
+**Where the seeds live.**  Inside `SelfAdequateConstStep`'s proof the
+constant witness is destructured together with its
+`RDeepChildren (CoherentSeedAt Γ₀ (depth+1))` tree.  The `const` branch
+of that tree (SLR:4170-4173) yields, per abstract `R` edge, the exact
+seed `pR : ∀ m e hr, CoherentSeedAt Γ₀ (depth+1) (hR m e hr)` and the
+child's own tree `cR`.  These seeds are attached to witnesses at the
+constant's ambient valuation ρ — and, crucially, the const case proves an
+`LR.Adequate` conclusion, so it works under an introduced
+`W : LR.SubstWF Γ₀ σ σ' Γ ρ` that pins that same ρ end to end.
+
+**Why the nil restatement is not available here.**  Transporting a seed's
+result to the `closedAt`-transported witness needs
+`CoherentRetainedAt Γ₀ hV d → CoherentRetainedAt Γ₀ (hV.closedAt cl) d`.
+Its `SelfAdequateAt` half quantifies over demands
+`LE_Interp.Witness Valuation.nil bx.T B → Adequate Γ₀ Δ Valuation.nil …`
+whose `Adequate` components quantify over `SubstWF … Δ Valuation.nil`;
+the only closed constructor is `.id` at `Δ = Γ₀`, `σ = σ' = .id`, and the
+ρ-stated result can never be instantiated there (no
+`SubstWF Γ₀ .id .id Γ₀ ρ` exists for a non-nil ρ).  The same wall blocks
+`RDeepChildren.closed` (SLR:5598): its `hP` premise is exactly this
+underivable stability.  So per-rule seeds *stated at nil witnesses* are
+not producible from the tree; a `SelfAdequateConstStep` conditional on
+them would be a hypothesis no producer can ever discharge.
+
+**What the standing note was actually protecting.**  The predecessor's
+rationale was "no `closedAt`-vs-`mono` commutation."  The commutation
+only arises when a per-witness seed must be threaded through
+`of_nonbotWitnessResult`'s `hmono` *and then* moved across a valuation
+change.  The kernel-checked `_coherent` consumer (ADQ:4697) already
+threads per-witness seeds through `hmono` via `CoherentRhsSeedAt.mono`
+with zero valuation transport, consuming the seed's `FixedHeadResultAt`
+at the caller's own `W`.  The const case has that `W`.  Decision:
+
+- The internal-leaf obligation is factored as
+  `LR.CoherentIotaLeafStep Γ₀`, stated at the ambient valuation with an
+  explicit `SubstWF Γ₀ σ σ' Δ ρ` input plus the per-edge seed family,
+  the per-edge child trees, and the strict-predecessor restart family —
+  the exact inventory `_coherent` + the chain fold will want.  No
+  `closedAt` appears anywhere in the const step, which satisfies the
+  note's operative content (no commutation obligation is ever created).
+- The nil-witness form remains the right interface where no caller
+  SubstWF exists — the bare global leaf — and is already served there by
+  the global-oracle consumer `_closedFixedHead` (ADQ:2956).  Nothing in
+  this decision forecloses it.
+
+**Second interface introduced.**  The stratified `const` rule carries
+only the constant's *type* certificate (SExpr:2383-2387); unlike the
+strong constructor it carries no definitional-unfold premise.  The
+unfold must therefore come from the witness's own `R` edge seed.  A
+genuine child's all-depth result covers the value's native stratified
+depth; a *local* (guarded-restart) seed is pinned to `depth+1` while the
+registered value's certificate depth is unrelated — the exact
+"registered premise deeper than the declared type" tripwire from the
+2026-08-14 rung audit, now localized.  That branch is factored as
+`LR.ConstDefnLocalStep Γ₀` (local seed on a registered definitional
+value extends to every certificate depth), keeping the provable branch
+proved and naming the budget question instead of patching it.
+
+— session-C subagent 3
+
+### SelfAdequateConstStep landed conditionally on two named leaf obligations (2026-08-15, session-C subagent 3)
+
+Baseline at resumption: green, zero errors, exactly one `declaration uses
+sorry` at the `LR.iotaWitnessStep` leaf (6540:8 before this session's
+insertions).  Reconfirmed by full elaboration before any edit; the same
+sole-sorry inventory holds after the landing (final log `main1`, exit 0:
+the one warning at the leaf statement, moved only by insertions to
+ADQ:6866, sorry token ADQ:6896; warning profile otherwise byte-identical
+to the baseline modulo line shifts).
+
+**Landed (kernel-checked; no new sorries; probe-verified first in
+`plans/probes/probeC2-conststep.lean` against the fresh olean, then ported
+verbatim):**
+
+- `LR.CoherentIotaLeafStep Γ₀` (ADQ:5820): the internal iota-leaf
+  obligation of the constant producer.  Inputs: the depth index, the
+  per-`R`-edge seed family `∀ m M hr, CoherentSeedAt Γ₀ depth (hR m M hr)`
+  and exact child trees (both drawn from the const witness's own
+  `RDeepChildren` const branch), `Ctx.WF Γ₀`, the ambient
+  `SubstWF Γ₀ σ σ' Δ ρ`, and the strict-predecessor coherent restart
+  family.  Output: level-polymorphic `IotaLeafDefEqAt Γ₀ level c ls
+  (Lower R)`.
+- `LR.ConstDefnLocalStep Γ₀` (ADQ:5848): the definitional-unfold budget
+  obligation — a local (guarded-restart) coherent seed on a registered
+  definitional value extends to the value's own certificate depths.
+- `LR.SelfAdequateConstStep.of_steps` (ADQ:5871, ~250 lines):
+  `Ctx.WF Γ₀ → CoherentIotaLeafStep Γ₀ → ConstDefnLocalStep Γ₀ →
+  SelfAdequateConstStep Γ₀`.  Everything else in the constant case is
+  proved outright — see the case inventory below.
+- `LR.CoherentSelfStep.of_leafSteps` (ADQ:6122): composition through
+  `coherentSelfStep_of_steps`, so the full self-adequacy half of the
+  coherent Nat algebra is now conditional on exactly
+  `defeqStep`-family + the two new Props (and `defeqStep` is itself one
+  hypothesis away via `SelfAdequateDefeqStepAt.of_lowerAdequacy` from the
+  bootstrap rungs).
+
+**Case inventory of the remake** (mirrors the old derivation-induction
+const case at `adequacy_of_iotaWitnessStep`, with every induction
+hypothesis replaced by witness-tree data):
+
+- Witness `bot` / `Const.bot`: unchanged bottom collapses.
+- `Const.lam` (the recursion): the constant-type observation that the old
+  proof took from `ihTy` is now
+  `(CoherentRetainedAt.restart lower (Nat.lt_succ_self depth)).1` at the
+  sound-transported witness of the type — legitimate because the
+  stratified `const` rule carries the type certificate at the strictly
+  smaller `depth`.  The reached leaf callback `evalPat` is
+  `PatternLeafDefEqAt.of_iota (leafStep (depth+1) hR hΓ₀ W pR cR lower k)`
+  — the witness's own seeds, never the global sorried `iotaWitnessStep`.
+- `Const.ctor` / `Const.indTy`: the `IndTyHead` fact the old proof took
+  from `ihF` is recovered with no `F`-bundle at all: the same `lower`
+  restart at the type witness, `toValTy` landing at the unfold-forced
+  `.indTy` type shape, and the definitional `TyDefEq`-at-`.indTy`
+  conjunction (the `indTy_m` simp lemma is `rfl`; the projection form
+  needs the definitional bridge, not the simp set).
+- `Const.pat` (nullary = definitional unfold): the old `ihDef` is
+  replaced by the seed on the witness's own `R` edge (`Lower R` at the
+  registered value).  Genuine child (`inl`): the all-depth result is
+  consumed at the value's native stratified depth from
+  `defn_whRed (Γ := Γ)` + `stratify`, then the goal closes by
+  `(LR Γ₀).whr` along `defn_whRed (Γ := Γ₀)`'s one-step reduction.
+  Local child (`inr`): `ConstDefnLocalStep` — the one branch with a real
+  depth-budget gap (below).
+
+**The seed-interface decision** is recorded in full in the preceding
+section ("SelfAdequateConstStep interface decision", same date): seeds
+stay at the ambient valuation pinned by the caller's `SubstWF`; the
+`Valuation.nil` restatement demanded by the earlier design note is not
+producible from the tree (per-edge retained results quantify over
+`SubstWF` at their own valuation and do not transport across `closedAt`;
+`RDeepChildren.closed`'s `hP` premise is that same underivable
+stability), while the ambient-`W` interface is exactly what the
+kernel-checked `_coherent` consumer threads with zero valuation
+transport, so the note's operative content — never create a
+`closedAt`-vs-`mono` commutation obligation — is satisfied by
+construction.
+
+**What discharging each hypothesis takes:**
+
+1. `CoherentIotaLeafStep` is the chain wall, scoped: split the joint
+   `RecursorIotaPattern` match (the `Matches.app` inversion already used
+   by the bare leaf at ADQ:6866), normalize the major's free-closure
+   `CtorDefEq` through `CtorDefEq.toChain` + rectangles, retype interior
+   vertices with strictly-smaller bounded inversion
+   (`JointStratifiedPathInversionAt.of_predecessorAdequacy`, ADQ:584),
+   and per exact link run `iotaDefEq_of_ctorExactAt_coherent` (ADQ:4697)
+   with `hP := CoherentRhsSeedAt.of_seed` applied to the received seeds —
+   the right-injection branch needs the RHS typing raised to the seed's
+   index, which is the same rung-audit question as item 2's.  Note the
+   Prop hands over the raw `NatSeed` family untruncated plus the child
+   trees, so the discharger keeps every option (including per-edge
+   sub-restarts).  If the discharge turns out to need the constant's own
+   type certificate as well, extend the Prop — it has exactly one call
+   site (ADQ:6017, the `evalPat` construction).
+2. `ConstDefnLocalStep` is the localized "registered premise deeper than
+   the declared type" tripwire from the 2026-08-14 rung audit.  Two known
+   discharge routes, to be decided at assembly time: (a) prove that the
+   coherent tower only ever attaches local seeds to definitional-value
+   edges together with a budget covering the value's certificate (then
+   this Prop follows from the producer invariant — likely requires
+   enriching `CoherentSeedAt`'s right injection with the coupled typing,
+   the same enrichment `CoherentRhsSeedAt` models one level up); or
+   (b) show closed registered values admit depth-extension of local
+   coherent results directly.  Route (a) is an ADQ-file interface change
+   with wide transport-lemma ripple; deliberately not attempted this
+   session (two-strikes discipline).
+
+**Opportunistic extension not attempted.**  The gate condition (short
+hypothesis list) was met, but `CoherentFixedHeadStep`'s missing N2 piece
+is the one OPEN interface decision the predecessor explicitly declined to
+commit (`LowerSyncAt` / widened `hcap`), and it must be a prose decision
+first.  With the session budget spent on the const landing and the
+elaboration cycle, writing that decision well was not affordable; wiring
+a skeleton conditional on an uncommitted N2 shape would be exactly the
+premature commitment the pause was protecting against.
+
+**Remaining tower (updated):**
+
+1. `LR.CoherentIotaLeafStep Γ₀` (new, hard): the chain fold against the
+   received seeds — this is where the G4 rung audit resolves (interior
+   retyping depths vs the rung index).
+2. `LR.ConstDefnLocalStep Γ₀` (new, medium): the local-seed budget for
+   definitional values, routes (a)/(b) above.
+3. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4588, unchanged; medium once N2 is
+   stated in prose): ordered spine→`FixedHeadTelescope` producer over the
+   in-file `peelLayer`.
+4. Assembly: `CoherentRetainedNatStep.of_steps` (ADQ:4601) from
+   `CoherentSelfStep.of_leafSteps` (ADQ:6122) + item 3, then the bare
+   leaf per rung via `iotaDefEq_of_ctorExactAt_natStep` (ADQ:4646) and
+   the bootstrap (`contextualAdequacyAtDepth_of_iotaSteps`, ADQ:6829).
+
+— session-C subagent 3
+
+### The chain wall resolves as a G4 tripwire; the residual is named and wired (2026-08-15, session-C subagent 4)
+
+Baseline at resumption: green, exit 0, zero errors, exactly one
+`declaration uses sorry` at `LR.iotaWitnessStep` (6866:8 before this
+session's insertions).  Reconfirmed by a full elaboration before any edit
+(log `baseline`).  Final state after the landings below (log `edit1`, exit
+0): zero errors, the same sole sorry warning at the same leaf statement,
+moved only by insertions to ADQ:6985 (sorry token ADQ:7015).  The warning
+profile is otherwise identical modulo line shifts, plus two new instances
+of the file's already-accepted `unusedSectionVars` lint (56 → 58) for the
+two new theorems that do not use `[Params.Semantic]`.
+
+**Primary target `LR.CoherentIotaLeafStep Γ₀` (ADQ:5884): obstruction, not
+a landing.  The rung audit fires the G4 tripwire.**  Per the standing
+instruction the discharge line was stopped rather than patched, and the
+residual was factored, named, and given both a producer and a consumer so
+that it is a checkable object rather than a narrative.
+
+#### The rung audit — the depth arithmetic, spelled out
+
+The journaled recipe survives its first three steps and dies at the fourth.
+Splitting the joint `RecursorIotaPattern` match and normalizing the major's
+free closure through `LRS.CtorDefEq.toChain` (SLR:11390) are available.
+More importantly, **every per-link consumer is inversion-free**: neither
+`LRS.iotaDefEq_of_ctorExactAt_coherent` (ADQ:4751) nor the synchronized
+rectangle `LRS.iotaDefEqRect_of_ctorExactAt` (ADQ:2887) takes a uniqueness,
+inversion, or subject-reduction premise, and `LogRel.DefEqRect.trans`
+(SLR:9960) composes shared-middle rectangles with pure logical-relation
+transitivity.  So the *entire* residual is the fold that carries the
+rectangle along the normalized chain.
+
+That fold spends exactly two facts, and both are unbounded:
+
+1. **Interior-vertex retyping.**  `LRS.CtorPath.foldRaw` (SLR:11072) calls
+   `uniq hXY.hasType.1 hX` once per link, where `hXY : IsDefEq Γ₀ X Y
+   A_link` is the link's own result type from `CtorExact.rawDefEq`
+   (SLR:10937) and `hX : IsDefEq Γ₀ X X D` anchors the vertex at the
+   recursor's major domain `D = pair.domain`.  `uniq : LogRel.RawTypeUniq
+   Γ₀` (SLR:10446) has exactly one producer in the tree,
+   `IsDefEq.uniq_of_stratified_inversion` (ADQ:646), whose induction is on
+   `max n₁ n₂` for the two *existentially obtained* stratification depths
+   of the vertex (`(h.strong hΓ).stratify`, ADQ:276-277, inside `uniqPath_of_stratified_inversion`) and which consumes
+   the **unbounded** `JointStratifiedInversion`.  That package's only
+   producer is `JointStratifiedInversion.of_adequacy` (ADQ:594) from
+   `LR.ContextualAdequacyAt 1` — full level-one adequacy at *every* depth.
+   At rung `d` the leaf holds only `∀ d' < d, ContextualAdequacyAtDepth d'`.
+2. **Root subject reduction.**  `LRS.CtorChain.foldRaw`'s two root
+   callbacks (SLR:11185) must move each major to its classified constructor
+   spine at `D`; the only producer is
+   `WHRedS.defeq_of_stratified_inversion` (ADQ:841), which internally
+   spends `uniq_of_stratified_inversion` again at the reducing term's own
+   depth.  Same unbounded package.
+
+**Why no certificate reachable at the leaf bounds the depth in (1).**  Three
+candidate bounds were checked and all fail, for three different reasons:
+
+- *The rung index `d`.*  The bootstrap deliberately does not hand the
+  produced rung's own certificate to the leaf (`_hstrat` at ADQ:6955; the
+  docstring at ADQ:6943-6947 states why: the derivation induction is
+  depth-blind, so a left-endpoint certificate cannot bound the leaf
+  instances reached through `trans` or evaluator descent).  This is
+  subagent 2's honesty note and it is load-bearing here.
+- *The registered-rule certificates `rhsStratified` / `headStratified`
+  (SLR:9280-9285).*  These are the ones the 2026-08-14 audit nominated, and
+  they are the wrong side of the redex.  They bound the *contractum* — the
+  applied RHS and its peeled fixed head, the latter exactly
+  `capturePaths.length` shallower.  The chain lives on the **major**, i.e.
+  the redex's inspected argument.  No arithmetic connects them.
+- *The redex's own stratification, hypothetically granted.*  This is the
+  decisive one.  Even if the leaf were handed
+  `HasTypeStratifiedS Δ (rec … major) B core D`, `HasTypeStratifiedS.app`
+  (SExpr:2388) would bound only the two **endpoint** majors at `D - 1`.  The
+  chain's *interior* vertices are the middle terms of `LRS.CtorDefEq.trans`
+  (SLR:10712), which relates `M ≡ N` and `N ≡ P` while retaining nothing
+  whatsoever about `N` — no typing, no shape, no certificate.  An interior
+  vertex is an arbitrary term of the ambient theory whose stratified depth
+  is not a function of the endpoints' depths at all.  **This is the exact
+  failing vertex.**
+
+So the demand is not "inversion at some depth `< d`" that we failed to
+arrange; it is "inversion at a depth that no premise in scope names".  There
+is no depth arithmetic that makes it strictly-predecessor, and manufacturing
+the package inside the proof would be precisely the same-rung
+self-consumption G4 forbids.  Extending `CoherentIotaLeafStep`'s inputs with
+the strict-predecessor contextual family therefore does **not** help, which
+is why the sanctioned "extend the Prop, there is one call site" escape hatch
+was not taken.
+
+**The repair that would close it is not local, and it is not in this
+session's territory.**  The erasure-north-star fix is to stop erasing the
+middle vertex: index `LRS.CtorDefEq`/`CtorLink`/`CtorPath`/`CtorChain` by
+the raw domain and have `trans` retain `IsDefEq Γ N N D`, after which
+`CtorPath.foldRaw` needs no `uniq` at all.  That is a ShapeLogRel.lean
+change and it was **not** attempted; more importantly it does not stay
+local: `LRS.CtorDefEq` is consumed through `LRS.IndDefEq` (SLR:11544), whose
+`trans` (SLR:11560) is the `trans` field of the `LogRel` record (SLR:9927),
+and `LogRel` carries **no** raw-typing projection at all — `DefEq M N A m a`
+does not imply `IsDefEq Γ M N A`.  So a strengthened `CtorDefEq.trans` would
+make `IndDefEq.trans` underivable unless the logical relation itself is
+given a soundness field, and that field's own `whr`/`unwhr` closure
+conditions (SLR:9937) are subject reduction, i.e. the inversion package
+again.  **Exact needed change, for the record:** either (i) `LRS.CtorDefEq`
+gains a raw domain index with `trans` retaining the middle vertex's
+self-typing *and* `LogRel` gains a raw-soundness field discharging
+`IndDefEq.trans`'s new premise, or (ii) an environment-level discipline on
+constructor result types (each constructor's instantiated result type is
+determined by the constructor and its arguments) replaces general raw
+uniqueness at exactly these vertices.  Route (ii) is the cheaper-looking one
+and is untouched research.
+
+**A second, independent blocker in the same fold, for whoever resumes.**  It
+is mechanical, not circular, and it was not visible in the journaled recipe.
+`CtorChain.RawAlgebra.exact` hands over a *framed* native leaf: `CtorFrame
+Γ₀ (LR Γ₀) m J p` plus `CtorExact Γ₀ J X Y p` at the leaf's own level `k`
+and shape `p`.  `iotaDefEqRect_of_ctorExactAt` pins the leaf's level to the
+ambient recursor level (`out`/`outTy : WShape (nI+1)` are fixed by the
+goal), and `CtorExact` has **no** level transport by design — its only
+lemmas are `toCtorDefEq`, `symm`, `rawDefEq` (SLR:10912-10945), because
+frames exist precisely to keep transports outside the native leaf
+(SLR:10858-10861).  So the fold must run the iota *natively* at level `k`
+and transport the finished rectangle back through the frame.  The parts for
+that exist: `LE_Interp.Matches.lift`/`.unlift` (SLR:5287/5416) move the
+match, `LE_Interp.RHS` is level-erased (`TShape`-valued) and needs no
+transport at all, and `LogRel.LiftEquiv.rect` (SLR:10783) is exactly the
+rectangle's transport iff.  Budget this as a real second layer.
+
+#### Landed (kernel-checked; no new sorries)
+
+- `LR.MajorChainFoldStep Γ₀` (ADQ:960): the named residual of the
+  normalized-chain fold, as a two-field structure — `uniq :
+  LogRel.RawTypeUniq Γ₀` and `subjectRed : WHRedS Γ₀ e₁ e₂ → IsDefEq Γ₀ e₁
+  e₁ A → IsDefEq Γ₀ e₁ e₂ A`.  Stated as two separate fields rather than
+  bundled as `JointStratifiedInversion` on purpose: a future producer may
+  reach either half by other means (route (ii) above reaches the first
+  without the second), and the fold consumes nothing else.
+- `LR.MajorChainFoldStep.of_stratifiedInversion` (ADQ:972): the completed
+  inversion package supplies both fields.  This certifies that the two
+  named facts are *precisely* what the existing
+  `foldRaw_of_stratifiedInversion` consumer spends — nothing else is hidden
+  in the package, so the factorization is faithful rather than convenient.
+- `LRS.CtorDefEq.foldRaw_of_majorChainFoldStep` (ADQ:981): the consumer.
+  The free constructor-observation closure folds from the named residual
+  alone, with no well-formedness hypothesis and no inversion package in
+  sight.  The Prop is therefore both produced and consumed in-file, not a
+  dangling definition.
+- `LR.ConstDefnDeepStep Γ₀` (ADQ:5941) and
+  `LR.ConstDefnLocalStep.of_deepStep` (ADQ:5957): the secondary target's
+  reduction (below).
+- `LR.CoherentSelfStep.of_leafStepsDeep` (ADQ:6241): the same assembly as
+  `of_leafSteps` (ADQ:6229) against the strictly smaller definitional
+  obligation, so the new Prop reaches the top-level composition.
+- Docstring on `LR.CoherentIotaLeafStep` (ADQ:5884) now records the audit
+  status inline, so the next reader of the Prop does not re-derive it.
+
+#### Secondary target `LR.ConstDefnLocalStep` (ADQ:5912): route (b) refuted, obligation strictly reduced
+
+Route (b) — "closed registered values admit depth-extension of local
+coherent results directly" — is **not** provable from closedness, and the
+reason is structural rather than a missing lemma.  `LR.SelfAdequateAt`
+(ADQ:3796) mentions its depth index in exactly one place, the stratified
+certificate it *consumes*; its conclusion `LR.Adequate …` is depth-free.
+Since `HasTypeStratifiedS.mono` (SExpr:2414) raises a certificate to any
+larger index, `SelfAdequateAt` is *stronger* at larger depth, and a local
+seed at index `depth` already discharges every `depth' ≤ depth` with no
+hypothesis at all.  All residual content is the strictly deeper case — and
+closedness of the value says nothing about it: `value.Closed` constrains
+substitution (`closed.mkInstS.subst_eq`), not stratification depth.
+
+The real content of that residual is worth stating plainly, because it is
+the same family of finding as the chain wall: **the stratified-depth measure
+does not decrease along δ-unfolding.**  The stratified `const` rule
+(SExpr:2383-2387) certifies only `SExpr.mkInst ls ci.type`; a definitional
+value is routinely far deeper than its declared type (`def foo : Nat := ⟨big
+term⟩`), so no environment-independent inequality can bound the value's
+depth by the constant's.  The old derivation induction handled this because
+`Params.Semantic.defn`'s equality is a *subderivation*; the witness-tree
+remake replaced derivation induction with a Nat recursion whose index simply
+does not travel across δ.  Note the call site is not rescued by the easy
+half either: it obtains `nV` from `hdefΓ.stratify` (ADQ:6212), and
+`.mono` lets that be taken arbitrarily large, so the `≤` half never applies
+there.  Route (a) — couple the budget to the seed at its creation point, as
+`CoherentRhsSeedAt` (ADQ:3976) already models one level up, with the budget
+derived from the *value's* certificate rather than the constant's — remains
+the only route, and it must be a producer-side change.  Deliberately not
+implemented (two-strikes; wide transport ripple), exactly as the predecessor
+scoped it.
+
+What landed is the honest reduction: `ConstDefnLocalStep.of_deepStep`
+(ADQ:5957) proves the whole `depth' ≤ depth` half unconditionally by
+`HasTypeStratifiedS.mono`, spending **no** adequacy content — it is pure
+depth arithmetic — leaving `ConstDefnDeepStep` (ADQ:5941) as a strictly
+smaller obligation stated only for `depth < depth'`.
+
+#### N2 capture-domain interface decision (prose, per the two-strikes rule)
+
+The one open design decision, stated before any Lean, as required.  The
+2026-08-14 N2 entry already ruled out pointwise widening of
+`CaptureDefEqAligned` and adopted the joint two-telescope route, which is
+landed as `LR.FixedHeadTelescope` (ADQ:1775) with `nil`/`cons`
+(ADQ:1839/1854) and the N1 layer core `WShape.HasTypeLam.peelLayer`
+(ADQ:1797).  What was left open is narrower and is the actual N2 question:
+the telescope *synthesizes* its head-type observation from the captures
+(`cons` builds `forallE tyDom tyFun` with `tyDom := capture`'s own
+`typeShape`), while `LR.FixedHeadResultAt` (ADQ:2148) must consume a head
+that observes the **registered** type `SExpr.mkInst recLs rule.df.type`.
+Something must link the two.  The alternatives:
+
+- **(i) Widened threading.**  Add the probe's `probeB.LowerSyncAt`
+  (plans/probes/probeB-2.lean:63) to the tower's per-witness invariant: on
+  demand from `head ≤ root`, a stratified certificate and `Fits`, it yields
+  `∃ headElem headTy, headElem ≤ head ∧ headElem.HasType headTy ∧ Nonempty
+  (Witness ρ headTy B)`, instantiated at `B :=` the registered type.  Its
+  threading through the unary recursor is PROVED
+  (`probeB.widenedThreading`).
+- **(ii) State the link on the consumer's premise.**  Replace
+  `FixedHeadResultAt`'s third premise — today the context-free fallback
+  `(∃ headElem headTy, headElem ≤ head ∧ headElem.HasType headTy)`,
+  ADQ:2171-2172 — by the ordered telescope itself together with
+  `Nonempty (Witness ρ headTy (SExpr.mkInst recLs rule.df.type))` stated at
+  the **telescope's own** `headTy` index.
+
+**Decision: (ii).**  The argument is the eight-failure erasure pattern, and
+it is decisive.  Option (i)'s conclusion is a *fresh* existential: the
+invariant chooses some `headElem`/`headTy` pair, while the telescope has
+already chosen the pair that every layer's `AtShapes` is indexed by.  Two
+independently chosen shape pairs for the same head, with a reconciliation
+obligation between them, is erasure #7 recurring one level up — the very
+shape the 2026-08-14 entry rejected when it refused a standalone per-path
+field ("a standalone field for each path cannot certify that its alleged
+domain is the domain selected by the *same* registered-type observation").
+Wrapping the semantic component in `Nonempty` makes it worse, not better:
+the consumer receives a witness it provably cannot align with its own
+telescope indices.  Option (ii) creates no reconciliation obligation at all,
+because there is only ever one pair per layer, chosen once, and the
+registered-type witness is attached to that same index.  This is also
+verbatim what the 2026-08-14 decision already prescribed for the completed
+certificate ("`FixedHeadResultAt` will consume that synchronized endpoint …
+the current context-free `typedLowerHead` input remains useful only as the
+shape fallback and must not be used to manufacture the final witness"), so
+(ii) is continuation rather than a new commitment.
+
+Note also that `widenedThreading` being PROVED argues only that the widening
+is *possible*; it was recorded in the 2026-08-14 synthesis under "verified
+non-risks", i.e. as evidence that adopting it would not break the recursion —
+not as evidence that it should be adopted.
+
+**Consequence, and why `CoherentFixedHeadStep` (ADQ:4642) was not attempted
+after the decision.**  Decision (ii) is an interface change to
+`FixedHeadResultAt`/`FixedHeadResult` (ADQ:2101/2148) with an enumerable but
+real ripple — `iotaDefEq_of_ctorExactAt_fixedHead`, `_closedFixedHead`,
+`_coherent`, `FixedHeadResult.mono`, `FixedHeadResult.of_forall_at`, and the
+`CoherentRetainedResult.fixedHead` projection.  Landing the premise change
+and the ordered producer in one session, after the audit and its elaboration
+cycles, would have put the green state at risk for a partial result; wiring
+a skeleton against an unchanged premise would bake in the fallback the
+decision just rejected.  The next session should land the premise change
+first, as its own green step, and only then build the producer at the
+`constDefEq`/`Matches` materialization boundary where the registered-type
+evidence is still in scope.
+
+#### Remaining tower (updated)
+
+1. `LR.MajorChainFoldStep Γ₀` (ADQ:960, NEW, blocked): the chain wall,
+   reduced to two named raw facts.  Not reachable from any adequacy rung;
+   see the audit above.  Next moves are the two repairs named there, both
+   outside `ShapeLogRelAdequacy.lean` — (i) retain the middle vertex in
+   `LRS.CtorDefEq` plus a `LogRel` soundness field, or (ii) an
+   environment-level constructor-result-type discipline.  Recommend
+   scoping (ii) first: it is local to the vertices that actually occur.
+2. `LR.CoherentIotaLeafStep Γ₀` (ADQ:5884, still unproved): now known to
+   reduce to item 1 plus the mechanical multi-level frame layer.  Do not
+   re-attempt before item 1 has an answer.
+3. `LR.ConstDefnDeepStep Γ₀` (ADQ:5941, NEW, strictly smaller than the
+   retired-in-half `ConstDefnLocalStep`): the δ-unfold depth budget.  Route
+   (a), producer-side, with the budget taken from the value's own
+   certificate.
+4. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4642, unchanged): N2 is now decided
+   (option (ii) above).  Land the `FixedHeadResultAt` premise change first,
+   then the ordered producer over `peelLayer` (ADQ:1797).
+5. Assembly: `CoherentRetainedNatStep.of_steps` (ADQ:4655) from
+   `CoherentSelfStep.of_leafStepsDeep` (ADQ:6241) + item 4, then the bare
+   leaf per rung via `iotaDefEq_of_ctorExactAt_natStep` and the bootstrap
+   `contextualAdequacyAtDepth_of_iotaSteps` (ADQ:6948).
+
+One structural observation worth carrying forward, since items 1 and 3 are
+the same finding twice: the stratified-depth measure decreases along
+syntax-directed typing but **not** along the two moves the joint leaf
+actually needs — δ-unfolding (item 3) and free-closure transitivity on
+constructor observations (item 1).  A depth-indexed fixpoint cannot by
+itself reach either.  Both residuals are now named, so the next design pass
+can be about those two moves specifically rather than about the fixpoint.
+
+— session-C subagent 4
+
+### Chain-wall repair: the reconciliation moves to the constructor observation (2026-08-15, session-C subagent 5)
+
+Written before any Lean, as the prose-first rule requires.  The task was to
+discharge `LR.MajorChainFoldStep` (ADQ:960) by a structural change.  Below is
+the route comparison, the choice, and — because it is the part that decides —
+what the choice does *not* buy.
+
+#### What the fold actually spends, restated exactly
+
+`LRS.CtorPath.foldRaw` (SLR:11072) does not use `uniq` to type the middle
+term of a `trans`.  It uses it, once per link, to reconcile **two independent
+type observations of the link's left vertex**: the link's own natural result
+type `A` (from `CtorExact`'s retained `hspine : SpineWF Γ CHead args.reverse
+A`, surfaced by `CtorExact.rawDefEq`, SLR:10937) against the running anchor
+`D` threaded from the root.  For the first link the anchor is the recursor's
+major domain; for every later link it is `hXYD.hasType.2`, i.e. the anchor
+*transported by the previous link*.  So the residual is not "type the middle
+vertex" — the middle vertex is already typed at `D` by construction once the
+previous link has been retyped.  The residual is: **the link's own result
+type and the inherited anchor are two derivations that must be identified.**
+
+This restatement is what separates the two candidate routes, and it kills one
+of them outright.
+
+#### (R1) Retain the middle vertex — refuted, twice, and for a new reason
+
+The predecessor's R1 was "index `CtorDefEq` by the raw domain and have `trans`
+retain `IsDefEq Γ N N D`".  Two findings:
+
+- *The blocker the predecessor named is not fatal.*  The audit said a raw
+  component on `CtorDefEq`/`IndDefEq` cannot survive `whr`/`unwhr`, because
+  those closure conditions would become subject reduction.  That is true for a
+  component stated about `M` and `N` — but **not** for one stated about their
+  classified spines.  `LRS.CtorView.whr`/`.unwhr` (SLR:10955/10963) move a
+  view across a weak-head reduction in *both* directions using only
+  `WHRedS.determ_l … .ctorSpine`, i.e. weak-head determinism at classified
+  constructor spines.  A component of the form `∀ X, CtorView Γ M X → P X` is
+  therefore exactly whr-invariant with no subject reduction at all.  Recorded
+  because it is a reusable fact: the whr regress the audit feared is avoidable,
+  and any future raw component on the ctor branch of the relation should be
+  stated on views rather than on roots.
+- *R1 nevertheless fails, one level down.*  Even with whr survived, a
+  D-indexed `CtorDefEq` must produce `IsDefEq Γ X Y D` at its `exact`
+  constructor for the externally chosen `D`, and there the leaf has only its
+  own `A`.  The reconciliation is not removed; it is relocated to the leaf
+  **and simultaneously made harder**, because `LogRel.conv` (SLR:9930) changes
+  the raw type index `A` of `IndDefEq` using only `LRS.TyDefEq`, which at
+  `.indTy` is `IndTyHead Γ A ∧ IndTyHead Γ B` (SLR:11629) and carries *no* raw
+  type equality.  A raw component pinned to `IndDefEq`'s own `A` is destroyed
+  by `conv`.  So R1 must in any case be stated anchor-*polymorphically*, at
+  which point it is R2 with extra indices.  Two strikes; R1 abandoned.
+
+#### (R2) Constructor-result-type discipline — chosen, in the form below
+
+The chosen shape, and the reason it is the right one, is that it makes the
+reconciliation *anchor-polymorphic and leaf-local*:
+
+- `LRS.CtorRetype Γ X Y`: a two-field **transport**, `∀ D, IsDefEq Γ X X D →
+  IsDefEq Γ X Y D` and its right-hand mirror.  Not an existential, not a sort
+  equality: it is the retyping *action* the fold performs, retained as data.
+- `LRS.CtorAnchorDisciplineAt Γ IH m`: that transport is available for every
+  framed native leaf of the root observation, with the frame and the leaf both
+  in hand — exactly the signature `CtorPath.RawAlgebra.exact` (SLR:11064)
+  already receives, so the discipline is scoped to the leaves that actually
+  occur under the root shape rather than to the whole environment.
+- `LRS.CtorSpineTypeUniqPath Γ`: the environment-level statement the
+  discipline reduces to — *the declared result type of a registered
+  constructor determines the type of its applications*, path-valued.
+
+Every closure operation of the chain machinery is then free of new premises:
+`foldRaw`'s per-link `uniq` call is replaced by the leaf's own transport, and
+`trans` needs nothing, because after the first link the anchor travels with the
+term.
+
+**Why this survives the eight-failure erasure pattern.**  The north star is
+retain more; proof-relevant, positional, replayable; never truncate to
+Prop/existence what a consumer needs.  Judged against it:
+
+1. *Proof-relevant rather than existential.*  `RawTypeUniq`'s conclusion is
+   `∃ u, IsDefEq Γ A B (.sort u)` — the consumer must then pick `u` and
+   `defeqDF` by hand, and every call site re-chooses.  `CtorRetype` hands over
+   the transport itself, already applied to the right endpoint.  Nothing is
+   existentially quantified that a consumer must re-align.
+2. *Positional.*  The discipline is indexed by the *frame and leaf* of the
+   observation it serves, so a consumer cannot accidentally satisfy it with a
+   retyping of some other constructor spine.  This is the same discipline the
+   2026-08-14 N2 entry enforced when it refused a standalone per-path field:
+   one pair per position, chosen once.
+3. *Path-valued, so no premature collapse.*  `CtorSpineTypeUniqPath` returns
+   `TypeDefEqPath` (SLR:10121), not a single conversion.  `TypeDefEqPath`
+   exists precisely because adjacent type equalities may assign different
+   universes, and `TypeDefEqPath.collapse` (SLR:10460) charges *the whole of
+   raw type uniqueness* for the collapse.  Since the fold only ever transports
+   term equalities (`TypeDefEqPath.defeqDF`, SLR:10157), collapsing first
+   would be erasure #2 — throwing away the sequence a consumer never needed
+   flattened.  The reduction therefore never asks for it.
+4. *Additive.*  `CtorDefEq`, `CtorExact`, `IndDefEq` and `LogRel` are not
+   touched; the anchored fold lands beside the existing one.  No consumer of
+   the free relation loses anything it has today, and the old
+   `foldRaw_of_majorChainFoldStep` stays green as the reference consumer.
+
+**What the choice does not buy, stated plainly so the next session does not
+rediscover it.**  It does **not** make the residual reachable from a strict
+predecessor adequacy rung.  Interior vertices are still classified constructor
+spines of unbounded stratified depth, and *any* identification of two type
+observations of the same term must invert at least one of the two derivations:
+`HasTypeStratifiedS.app_inv` (SExpr:2613) walks a spine, but reconciling the
+two codomains at each application step is Pi inversion at that vertex's own
+depth.  There is no reformulation of the fold that escapes this — the two
+types genuinely originate in two independent derivations, so the repair must
+remove the *independence*, and the only place independence can be removed is
+the producer of constructor observations, where the constructor's declared
+type is available and there is exactly one of it.
+
+That is the whole content of the choice: the obligation is moved **out of the
+depth-indexed fixpoint** and onto the environment, where it has no depth index
+to be blocked on.  `MajorChainFoldStep` demanded `LogRel.RawTypeUniq Γ₀` for
+arbitrary terms plus subject reduction for arbitrary reductions; what replaces
+it demands a retyping only for terms carrying a native `CtorExact` certificate,
+plus subject reduction only for reductions **to a classified constructor
+spine** — and the latter, per the 2026-08-15 audit's own third bullet, is the
+one half a redex certificate does bound (`HasTypeStratifiedS.app`, SExpr:2388,
+bounds the two endpoint majors at `D - 1`).  Removing the interior demand is
+therefore what makes the endpoint bound worth having.
+
+— session-C subagent 5 (design decision; landing recorded below)
+
+#### Landed (kernel-checked; no new sorries; additive, zero ripple)
+
+Baseline at resumption, reconfirmed by a full elaboration before any edit (log
+`baseline-adq`, exit 0): zero errors, exactly one `declaration uses sorry` at
+the `LR.iotaWitnessStep` leaf, ADQ:6985:8.  Final state after everything below:
+zero errors in both edited files, `ShapeLogRel.lean` with zero sorries, the
+same sole sorry warning in `ShapeLogRelAdequacy.lean` at the same leaf
+statement, moved only by insertion to ADQ:7062:8.  Warning profile otherwise
+identical modulo line shifts, plus two further instances of the file's already
+accepted `unusedSectionVars` lint (81 → 83 file-anchored warnings) for the two
+new theorems that do not use `[Params.Semantic]`.  `ShapeLogRel.lean` gained
+no warnings beyond its existing profile.
+
+In `Lean4Lean/Experimental/ShapeLogRel.lean`:
+
+- `LRS.CtorRetype` (SLR:11112) and `.symm` (SLR:11119): the two-field retyping
+  transport of one native link.
+- `LRS.CtorSpineTypeUniqPath` (SLR:11135): the environment-level constructor
+  result-type discipline, path-valued.
+- `LRS.CtorSpineTypeUniqPath.of_rawTypeUniq` (SLR:11147): raw type uniqueness
+  supplies it by a single-edge path — the faithfulness certificate that the
+  new obligation is *implied by* the one it replaces.
+- `LRS.CtorExact.retype_of_ctorSpineTypeUniqPath` (SLR:11161): the discipline
+  retypes any native exact link.  The right-endpoint field is the interesting
+  one: it applies the discipline twice at that endpoint's own spine
+  certificate — once against the link's type, once against the requested
+  domain — and composes the two paths.  No sort index is ever identified, so
+  `TypeDefEqPath.collapse` (and with it the whole of raw type uniqueness) is
+  never charged.
+- `LRS.CtorAnchorDisciplineAt` (SLR:11188) with `.of_ctorSpineTypeUniqPath`
+  (SLR:11194) and `.of_rawTypeUniq` (SLR:11200): the frame-scoped form the
+  folds consume.
+- `LRS.CtorPath.foldRaw_of_anchorDiscipline` (SLR:11210),
+  `LRS.CtorPath.rawDefEqAt_of_anchorDiscipline` (SLR:11229),
+  `LRS.CtorChain.foldRaw_of_anchorDiscipline` (SLR:11356),
+  `LRS.CtorChain.rawDefEqAt_of_anchorDiscipline` (SLR:11374),
+  `LRS.CtorDefEq.foldRaw_of_anchorDiscipline` (SLR:11625),
+  `LRS.CtorDefEq.rawDefEqAt_of_anchorDiscipline` (SLR:11636): the complete
+  raw-consumer surface of the chain machinery, re-landed without
+  `LogRel.RawTypeUniq`.  All six have the same statements as their `uniq`-taking
+  originals (SLR:11041/11072/11155/11185/11416/11428), which are untouched.
+
+In `Lean4Lean/Experimental/ShapeLogRelAdequacy.lean`:
+
+- `LR.MajorChainAnchorStep Γ₀` (ADQ:1015): the repaired residual, two fields —
+  `ctorRetype` (per-framed-leaf transport) and `rootRed` (subject reduction *to
+  a classified constructor spine*, i.e. the two root views only).
+- `LR.MajorChainAnchorStep.of_ctorSpineTypeUniqPath` (ADQ:1030): the intended
+  producer, taking the environment-level discipline directly.
+- `LR.MajorChainAnchorStep.of_majorChainFoldStep` (ADQ:1040): the old residual
+  implies the new one, so this is a weakening and not a restatement.
+- `LRS.CtorDefEq.foldRaw_of_majorChainAnchorStep` (ADQ:1053): the consumer.
+  Identical statement to `foldRaw_of_majorChainFoldStep` (ADQ:981), which stays
+  green beside it as the reference consumer.
+- The status paragraph of `LR.CoherentIotaLeafStep` (ADQ:5961) now records the
+  repair and the surviving mechanical multi-level frame layer inline.
+
+**Ripple: none, by construction.**  `LRS.CtorDefEq`, `LRS.CtorExact`,
+`LRS.CtorLink`, `LRS.CtorPath`, `LRS.CtorChain`, `LRS.IndDefEq` and `LogRel`
+are untouched — no constructor gained a premise, no structure gained a field,
+so not one existing consumer changed.  Enumerated before editing: the free
+relation is reached through `IndDefEq` (SLR:11544 pre-edit) which is the ctor
+branch of `LR`, hence through `LogRel`'s `trans`/`whr`/`conv`; every one of
+those would have been a breaking site under R1.  Landing beside the existing
+fold instead of inside it avoids all of them, as the additive-first rule
+prefers.  `LogRel.RawTypeUniq` still has its original consumers; nothing was
+removed.
+
+#### What `MajorChainFoldStep` now reduces to
+
+Precisely, and with the honest limits stated:
+
+1. **Interior of the chain: discharged outright.**  `CtorPath.foldRaw` used to
+   call `uniq` once per link.  `CtorPath.foldRaw_of_anchorDiscipline` calls
+   nothing: the link retypes itself and its retyped right endpoint anchors the
+   tail.  The unbounded family of interior obligations is gone from the
+   consumer, not renamed.
+2. **Per native leaf: `LRS.CtorSpineTypeUniqPath Γ₀`.**  This is where the
+   payment now sits, and it has *no depth index at all* — it has left the
+   depth-indexed fixpoint.  Its subject is a registered constructor
+   application with its head typing and spine certificate retained; its
+   content is that a registered constructor's declared result type is the type
+   of its applications.
+3. **At the two roots: `rootRed`.**  Weak-head subject reduction restricted to
+   reductions that land on a classified constructor spine.
+
+**A correction to the 2026-08-15 audit's endpoint claim, since it matters for
+whoever discharges item 3.**  The audit observed that a redex certificate
+bounds the two endpoint majors at `D - 1` (`HasTypeStratifiedS.app`,
+SExpr:2388), and that reads as though `rootRed` is therefore reachable.  It is
+not, quite: `WHRedS` is the reflexive-transitive closure, and
+`WHRedS.defeq_of_stratified_inversion` (ADQ:841) inducts along the sequence
+taking each next step's typing from `ih.hasType.2` — an `IsDefEq` whose own
+stratified depth is existential.  The redex certificate bounds the *first*
+step only.  So item 3 is a well-posed *local* target — one reduction sequence
+from one bounded term — but it needs a subject-reduction lemma that
+re-certifies each reduct, which does not exist yet.  Worth noting that the
+single-step producer's one uniqueness use in the registered-action case
+(`uniq hcore.hasType action.sound.hasType.1`, ADQ:836) is on the *contractum*,
+which is exactly the side `rhsStratified`/`headStratified` (SLR:9280-9285) do
+bound — so for the root callbacks, unlike for the interior, the registered-rule
+certificates are on the right side of the redex after all.
+
+#### Secondary: `LR.ConstDefnDeepStep` (ADQ:6018) — not landed, and deliberately not faked
+
+The instruction was to look for whether the primary repair also serves the
+δ-unfold budget.  It does, as a *principle*, and not as a lemma; both halves
+are worth recording.
+
+The principle transfers exactly.  The call site (ADQ:6284) obtains the value's
+stratification depth by `obtain ⟨nV, -, hstratV⟩ := hdefΓ.stratify` — an
+existential index re-chosen at consumption time — and then needs
+`SelfAdequateAt Γ₀ hV nV` while the local seed offers only `depth + 1`.  That
+is the same erasure as the chain wall: an index the producer already knew is
+discarded and re-chosen downstream.  The repair is the same shape too — retain
+it at creation, i.e. give the local (`NatSeed` right-injection) branch on a
+registered definitional edge the value's own certificate at the seed's index,
+exactly as `CoherentRhsSeedAt` (ADQ:4048) already does one level up — after
+which the call site consumes the retained certificate and the deep case
+disappears entirely rather than being discharged.
+
+The lemma does not transfer.  For the chain, the obligation's *subject* could
+be narrowed (from arbitrary terms to certified constructor spines) and that
+was enough.  Here the obligation is a universally quantified *index*
+(`∀ depth', depth < depth' → SelfAdequateAt Γ₀ hV depth'`), and no leaf-local
+retention weakens a quantified index — only bounding the demand does, which is
+a producer-side change to the seed interface with the transport ripple the
+predecessor already scoped.  Two strikes on route (b) (refuted), route (a) not
+attempted.
+
+One thing was deliberately *not* done, and the next session should not do it
+either: factoring `ConstDefnDeepStep` through a "certificate lowering" Prop of
+the form `HasTypeStratifiedS Δ X B core depth' → HasTypeStratifiedS Δ X B core
+depth`.  That reads like the analogous narrowing but is underivable, and worse,
+false in spirit: `HasTypeStratifiedS.defeq` (SExpr:2405) lets a certificate
+reach an arbitrary type `B` at an arbitrary larger index, so no lowering to a
+seed index chosen by an unrelated guarded restart can hold.  It would be a
+hypothesis no producer could ever discharge — the exact failure mode the
+2026-08-15 interface-decision section rejected for nil-restated seeds.
+
+#### Tertiary: not attempted
+
+Gated on the secondary being resolved, which it is not.  The N2 decision
+(option (ii)) and its ~five-consumer ripple stand exactly as the previous
+session left them.
+
+#### Remaining tower (updated)
+
+1. `LRS.CtorSpineTypeUniqPath Γ₀` (SLR:11135, NEW): the environment-level
+   constructor result-type discipline.  This is the interior half of the chain
+   wall, now outside the depth fixpoint.  It is the first residual in this
+   development that a *generation-side* argument can attack, because its
+   subject is a registered declaration rather than an arbitrary derivation.
+2. `LR.MajorChainAnchorStep.rootRed` (ADQ:1015): root subject reduction to a
+   classified spine.  Needs a re-certifying multi-step subject-reduction
+   lemma; see the correction above for why the redex certificate alone is not
+   enough and where the rule certificates *do* apply.
+3. `LR.CoherentIotaLeafStep Γ₀` (ADQ:5961, unproved): items 1 + 2 plus the
+   mechanical multi-level frame layer (run the rectangle natively at the
+   leaf's level `k`, transport back through `LogRel.LiftEquiv.rect`,
+   SLR:10783).
+4. `LR.ConstDefnDeepStep Γ₀` (ADQ:6018, unproved): route (a) only, as a
+   producer-side retention of the value's certificate at seed creation.
+5. `LR.CoherentFixedHeadStep Γ₀` (unchanged): N2 decided; land the
+   `FixedHeadResultAt` premise change first, then the ordered producer over
+   `peelLayer`.
+6. Assembly: `CoherentRetainedNatStep.of_steps` from
+   `CoherentSelfStep.of_leafStepsDeep` + item 5, then the bare leaf per rung
+   and the depth bootstrap.
+
+`LR.MajorChainFoldStep` (ADQ:960) and its two lemmas are kept, unused by the
+new path, as the reference statement of what the repair removed.
+
+**Build note for the fixture slice:** this session changed `ShapeLogRel.lean`
+and rebuilt only `Lean4Lean.Experimental.ShapeLogRel` and
+`Lean4Lean.Experimental.ShapeLogRelAdequacy`.  The D0/D1/D2 fixture oleans
+(`SExprParamsD0/D1/D2`) are stale by design and need a rebuild before they are
+trusted again.  The change is purely additive, so no fixture source edit is
+expected.
+
+— session-C subagent 5
+
+### The chain-wall residual collapses to Pi injectivity; both fields of `MajorChainAnchorStep` land (2026-08-15, session-C subagent 6)
+
+Baseline at resumption, reconfirmed by a full elaboration before any edit
+(log `baseline-adq`, exit 0): zero errors, exactly one `declaration uses
+sorry` at the `LR.iotaWitnessStep` leaf (ADQ:7062:8), plus `SExpr.lean`'s four
+off-path sorries.  Final state: zero errors in both edited files;
+`ShapeLogRel.lean` with **zero** sorries; `ShapeLogRelAdequacy.lean` with the
+same sole sorry at the same leaf, moved only by insertion to ADQ:7115:8 (token
+ADQ:7145).  Both warning profiles are **identical to baseline, not merely
+comparable**: `diff` of the two sorted, line-number-stripped warning sets is
+empty on both files (23 → 23 in `ShapeLogRel.lean`, 83 → 83 in
+`ShapeLogRelAdequacy.lean`).  Every landed declaration depends on nothing but
+`propext` / `Classical.choice` / `Quot.sound` — checked by `#print axioms` in
+`plans/probes/probeA6-spine.lean` — so no `sorryAx` is reachable and none of
+`SExpr.lean`'s off-path sorries is touched.
+
+Both remaining items of the previous session's tower are discharged.  They
+turned out to be the *same* obligation, and the obligation is smaller than
+either half was thought to be.
+
+#### The move: stop erasing the conversions a stratified typing already carries
+
+The predecessor's route comparison was right about where the payment sits and
+wrong about how much of it there is.  The decisive observation is an erasure
+repair one level below anything the previous four sessions inspected.
+
+`HasTypeStratifiedS.to_core` (SExpr:2580) strips the outer conversions of a
+stratified typing and returns only `∃ A', Γ ⊢ e :! A' !! n`.  It *throws the
+conversions away*.  That single discard is the entire reason
+`HasTypeStratifiedS.core_aligned_of_typeUniq` (ADQ:794) has to buy the
+alignment back with `LogRel.RawTypeUniq`, and therefore the reason every case
+of `WHRed.defeq_of_stratified_inversion` (ADQ:821) opens by spending the full
+`JointStratifiedInversion` package.  But the discarded conversions are
+`IsDefEqStrong … (.sort u)` edges — they already *are* a `TypeDefEqPath`.
+Retaining them costs nothing: `HasTypeStratifiedS.to_core_path` (SLR:11194) is
+the same induction as `to_core` with the path threaded, and its base case
+closes from `HasTypeStratifiedS.isType` (SExpr:2716), which every
+syntax-directed core derivation already carries.
+
+This is the north star applied to a lemma nobody had looked at: the producer
+knew the conversions, the consumer needed them, and the interface in between
+truncated them to an existential.  Everything below is what falls out.
+
+#### Target 1 — `LRS.CtorSpineTypeUniqPath` (SLR:11135): the generation-side argument
+
+With the path retained, the discipline reduces in three steps, of which the
+first two are *free* — no adequacy, no uniqueness, no inversion, nothing.
+
+1. **Any typing of an application spine already is a `SpineWF`.**
+   `HasTypeStratifiedS.spineWF_of_foldl` (SLR:11278): from
+   `Γ ⊢ es.foldl (·.app ·) hd : V !! n` one recovers a typing of `hd` together
+   with `SExpr.SpineWF Γ HdTy es V`.  The recursion is on the *argument list*,
+   not on a depth; each `app` node is exposed by `to_core_path`; and the
+   conversions that node discards are absorbed by `SpineWF.conv_path`
+   (SLR:11223), because `SpineWF` is already closed under conversion at both
+   ends (`conv`/`ret`, SExpr:1398-1405).  Nothing is identified anywhere.
+   Contrast `HasTypeStratifiedS.foldl_app_head` (SExpr:2629), which walks the
+   same spine and retains only the head — erasure of exactly the layer
+   structure this needs.
+2. **The head is a registered constant, and a registered constant has one
+   type.**  `LRS.constTypeUniqPath` (SLR:11304): two typings of `.const c ls`
+   are path-equal.  Both core derivations must be the stratified `const` rule,
+   whose displayed type is literally `SExpr.mkInst ls ci.type`; the
+   environment is a function, so `env.constants c = some ci₁` and
+   `= some ci₂` give `ci₁ = ci₂` and the two types are *syntactically
+   identical*.  The retained paths then compose.  **This step consumes
+   nothing at all.**  It is the generation-side content of the whole repair,
+   and it is why the residual has no depth index: its subject is a registered
+   declaration, and the fact used about it is settled at declaration time, not
+   at derivation time.
+3. **The two spine runs are compared layer by layer.**
+   `SExpr.SpineWF.result_path` (SLR:11345): two `SpineWF`s over the *same*
+   argument list from path-equal head types reach path-equal results.  Each
+   layer inverts the Pi that `SpineWF.cons_path` (SLR:11250) exposes as the
+   running path's right endpoint, then substitutes the shared argument into
+   the codomain path (`TypeDefEqPath.subst`, SLR:10184).
+
+Only step 3 has content, and its content is exactly **Pi injectivity for type
+paths**.  That is the single named residual, `LRS.PiPathInv` (SLR:11332):
+
+    ∀ {Γ A B A' B' s}, Ctx.WF Γ →
+      TypeDefEqPath Γ (.forallE A B) (.forallE A' B') s →
+      ∃ u v, TypeDefEqPath Γ A A' u ∧ TypeDefEqPath (A :: Γ) B B' v
+
+Three absences in that statement are load-bearing and were each a separate
+failure mode in earlier sessions.  *No stratification index* — unlike
+`JointStratifiedPathInversion.forallEInv` (ADQ:234) it demands no endpoint
+certificates, so no consumer must name a depth, and the G4 tripwire has
+nothing to fire on.  *No universe alignment* — `sortPathInv` is never used by
+any consumer below.  *No collapse* — the conclusion is again path-valued, so
+`TypeDefEqPath.collapse` (SLR:10460), which is the whole of raw type
+uniqueness, is never charged.  `LRS.PiPathInv.of_adequacy` (ADQ:267) is the
+producer, and it is `TypeDefEqPath.forallE_inv_of_adequacy` (ADQ:177)
+repackaged with nothing added — that theorem already requests no certificate.
+
+The general statement is `LRS.constSpineTypeUniqPath` (SLR:11373): *any* two
+typings of one fully-applied registered-constant spine are path-equal.
+`LRS.CtorSpineTypeUniqPath.of_piPathInv` (SLR:11393) is the instance.  Worth
+recording explicitly: **the proof never uses `Params.classify c = some (.ctor
+_)`.**  The result-type discipline is not special to constructors — it is the
+discipline of registered declarations, and the constructor classification only
+selects which spines the fold happens to meet.  That is the honest scope of
+route (ii) of the 2026-08-15 audit, and it is wider than the audit guessed.
+
+#### Target 2 — `rootRed` (ADQ:1040): the re-certifying lemma is not needed
+
+The brief for this session was to build a *re-certifying* multi-step subject
+reduction: one that carries the stratification certificate along the whole
+`WHRedS` rather than losing it after the first step, since
+`WHRedS.defeq_of_stratified_inversion` (ADQ:866) takes each next step's typing
+from `ih.hasType.2`, whose depth is existential.
+
+That design is correct as a diagnosis and unnecessary as a construction.  The
+obstruction is dissolved rather than answered: once the per-step lemma names
+no depth, the induction has nothing left to lose.  Re-proving the single step
+against the retained path, `WHRed.defeq_of_piPathInv` (SLR:11422):
+
+* `app` and `major` become **free** — their only cost was
+  `core_aligned_of_stratified_inversion`, and `IsDefEq.core_aligned_path`
+  (SLR:11212) supplies the same alignment with no premise;
+* `beta` spends **only `LRS.PiPathInv`**, in place of the collapsed
+  `inv.forallEInv`;
+* `extra` (a registered contraction) spends **only the spine discipline of
+  Target 1**.  `Pattern.MatchesS.head_spine` (SExpr:899) says a matched redex
+  *is* a constant-headed application spine, so its core type and the type
+  carried by `Pattern.Action.sound` are two typings of one registered spine —
+  reconciled by exactly the environment-level fact the constructor leaves use.
+
+`WHRedS.defeq_of_piPathInv` (SLR:11464) is then the three-line induction, with
+no certificate threaded and none needed.  The predecessor's correction about
+which side of the redex the rule certificates bound is therefore moot for this
+route: no side of the redex needs a certificate.  Note also that the general
+form is proved — the restriction of `rootRed` to reductions landing on a
+*classified* spine is never used, so that narrowing can be dropped from any
+future interface without cost.
+
+#### What this does and does not buy
+
+`LR.MajorChainAnchorStep.of_piPathInv` (ADQ:1092) discharges **both** fields
+from `LRS.PiPathInv` plus `Ctx.WF Γ₀`.  Measured against what
+`MajorChainAnchorStep.of_majorChainFoldStep` (ADQ:1065) needs — the collapsed
+`JointStratifiedInversion`, i.e. `IsDefEq.uniq_of_stratified_inversion`
+(ADQ:671, a well-founded induction on `max n₁ n₂`) *plus*
+`TypeDefEqPath.collapse_of_stratified_inversion` (ADQ:422) *plus* the sort
+inversion — this is a strict and large weakening.  `LRS.PiPathInv` is *implied
+by* the package it replaces: `LRS.PiPathInv.of_jointStratifiedPathInversion`
+(ADQ:276) is the faithfulness certificate, recovering the endpoint
+certificates `forallEInv` demands from the path's own two self-typings.
+
+What it does **not** buy, stated plainly so the next session does not
+rediscover it.  `LRS.PiPathInv` is still produced only from
+`LR.ContextualAdequacyAt 1`, so at a leaf inside the depth bootstrap it is not
+yet available.  The depth-*bounded* rung that does exist —
+`IsDefEqStrong.forallE_invPath_of_adequacyAtDepth` (ADQ:555), reachable from a
+strict predecessor family via `JointStratifiedPathInversionAt.of_predecessorAdequacy`
+(ADQ:609) — does **not** discharge `PiPathInv`, for a reason that is now
+precise rather than atmospheric: the Pis inverted by `SpineWF.result_path` are
+the types occurring along the spine of a *native chain leaf*, and those leaves
+are the chain's interior vertices, whose stratified depth the 2026-08-15 audit
+already showed is not a function of the endpoints'.  A bounded rung needs the
+Pi's own depth `≤ depth`; nothing names that depth.  So the residual is
+genuinely one proposition now, but it is still a proposition about the whole
+theory rather than about a predecessor rung.
+
+Two further consequences worth carrying, both free:
+
+* `IsDefEq.core_aligned_path` (SLR:11212) is a drop-in strengthening of
+  `IsDefEq.core_aligned_of_stratified_inversion` (ADQ:805) for every consumer
+  that only transports a term equality.  Any remaining call site of the latter
+  that does not then collapse is spending the full package for nothing.
+* `HasTypeStratifiedS.spineWF_of_foldl` (SLR:11278) turns any spine typing
+  into the retained layer certificate the generated-iota machinery already
+  speaks in.  It is the premise-free converse of `SpineWF.hasType`
+  (SExpr:1524) and should be reached for before any new spine inversion is
+  written.
+
+#### Item 3 (`LR.CoherentIotaLeafStep`, ADQ:6014): assessed, deliberately not started
+
+Per the brief this was to be attempted opportunistically if both targets
+landed.  It was assessed and not started, and the reason is a concrete
+specification rather than a budget excuse.
+
+The audit's second blocker — run the iota natively at the framed leaf's own
+level `k` and transport the finished rectangle back through
+`LogRel.LiftEquiv.rect` (SLR:10783) — is *not* mechanical, because of a shape
+mismatch that is easy to miss.  `LogRel.DefEqRect R M₁ M₂ N₁ N₂ A m a`
+(SLR:9946) is indexed by an **element** shape and a **type** shape, both
+`WShape n`.  `LRS.CtorFrame Γ IH m J p` (SLR:10862) is indexed by the two
+**constructor-observation** shapes, `WShape (n+1)` and `WShape (k+1)`, and
+carries no element or type shape at all.  So a standalone
+`CtorFrame`-indexed rectangle transport would have to *quantify* the element
+and type shapes and their `HasType`/`≤` side conditions (`DefEqRect.mono_l`
+SLR:9976, `.mono_r_1/2` SLR:9985/9995, and `LiftEquiv.rect`'s own `hma`).
+That is a second, independently chosen shape pair for one position — erasure
+#7, exactly the failure the N2 decision refused in the 2026-08-15 entry.
+
+The right construction therefore threads the element shape **positionally**
+from the leaf that already owns it, which makes it a producer-side step inside
+item 3's own leaf assembly, not a reusable lemma that can be landed first.
+Recorded so the next session builds it in the right place rather than
+manufacturing a plausible-looking transport lemma its consumer cannot align
+with.
+
+#### Remaining tower (updated, renumbered)
+
+1. `LRS.PiPathInv` (SLR:11332, NEW): path-valued Pi injectivity.  **The sole
+   residual of the chain wall**, replacing former items 1 and 2 in their
+   entirety.  Depth-free, universe-free, collapse-free; produced by
+   `LRS.PiPathInv.of_adequacy` (ADQ:267) from `LR.ContextualAdequacyAt 1`, and
+   implied by the existing path package (ADQ:276).  Not reachable from a
+   depth-bounded rung; see above for why.
+2. `LR.CoherentIotaLeafStep Γ₀` (ADQ:6014, unproved): item 1 plus the
+   multi-level frame layer, whose shape-threading specification is recorded
+   above.
+3. `LR.ConstDefnDeepStep Γ₀` (ADQ:6071, unproved): unchanged — route (a) only,
+   as a producer-side retention of the value's certificate at seed creation.
+4. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4767, unchanged): N2 decided; land the
+   `FixedHeadResultAt` premise change first, then the ordered producer over
+   `peelLayer`.
+5. Assembly: `CoherentRetainedNatStep.of_steps` (ADQ:4743) from
+   `CoherentSelfStep.of_leafStepsDeep` (ADQ:6371) + item 4, then the bare leaf
+   per rung and the depth bootstrap.
+
+`LR.MajorChainFoldStep` (ADQ:985) and `LR.MajorChainAnchorStep` (ADQ:1040) are
+both kept with all their producers, the former unused, as the reference
+statements of what two successive repairs removed.
+
+**Build note for the fixture slice:** this session changed `ShapeLogRel.lean`
+and `ShapeLogRelAdequacy.lean` and rebuilt only
+`Lean4Lean.Experimental.ShapeLogRel` and
+`Lean4Lean.Experimental.ShapeLogRelAdequacy`.  The D0/D1/D2 fixture oleans
+(`SExprParamsD0/D1/D2`) are stale by design and need the central rebuild
+before they are trusted again.  The change is purely additive — no existing
+structure gained a field, no existing theorem gained a premise, no existing
+statement changed — so no fixture source edit is expected.
+
+— session-C subagent 6
+
+### Two probe-verified ports land; the N2 premise change is in the file (2026-08-15, session-C subagent 7)
+
+Mechanical application of `plans/l4l-16c-port-queue.md` items 4 and 5(i)–(iii),
+from the green probes `plans/probes/probeH-constdefn.lean` and
+`plans/probes/probeF-telescope.lean`.  Three separate green builds of
+`Lean4Lean.Experimental.ShapeLogRelAdequacy`, one per port, in the queue doc's
+prescribed landing order.  Nothing outside `ShapeLogRelAdequacy.lean` was
+touched: `ShapeLogRel.lean` and `SExpr.lean` are byte-identical.
+
+#### Port 1 — retention + demand narrowing for the δ-definition budget (item 4)
+
+`LR.ConstDefnLocalStep` (ADQ:6232), `LR.ConstDefnDeepStep` (ADQ:6261) and
+`LR.ConstDefnLocalStep.of_deepStep` (ADQ:6277) are KEPT verbatim as reference
+statements, the same treatment `MajorChainFoldStep` received.  Landed beside
+them, verbatim from probeH modulo the `probeH.` → `LR.` rename:
+
+- `LR.ConstDefnLocalStepR` (ADQ:6311) and `LR.ConstDefnDeepStepR` (ADQ:6329) —
+  the retentive forms.  They keep the strictly smaller restart family `lower`
+  and `Ctx.WF Γ₀`, both of which were in scope at the sole call site and were
+  being erased on the way in.
+- `LR.ConstDefnDeepStepR.toLocal` (ADQ:6349) — the depth-arithmetic reduction,
+  threaded through the retained family.
+- `LR.ConstDefnDeepStepR.of_constDefnDeepStep` (ADQ:6359) and
+  `LR.ConstDefnLocalStepR.of_constDefnLocalStep` (ADQ:6366) — faithfulness:
+  the new Props are weakenings, so whatever discharges the old ones discharges
+  these.
+- `LR.ConstDefnDeepInstStep` (ADQ:6378) — the demand narrowing.  The call site
+  consumes exactly one instance of `LR.SelfAdequateAt`, pinned by
+  `Params.Semantic.defn_whRed` to `B := SExpr.mkInst ls ci.type`,
+  `core := true`; the certificate depth `nV` is now bound where the
+  certificate is supplied rather than universally ahead of it.
+- `LR.ConstDefnDeepInstStep.of_deepStepR` (ADQ:6405) — faithfulness for the
+  narrowed form, hence (composing) from the current `ConstDefnDeepStep`.
+
+Three consumers moved: `LR.SelfAdequateConstStep.of_steps` (ADQ:6426) now takes
+`LR.ConstDefnDeepInstStep Γ₀`, and its defn-local branch (ADQ:6661) is
+probeH's `callSiteInst` body — the `have hself : SelfAdequateAt … ` is replaced
+by a directly ascribed `have adV : LR.Adequate …`, so no index-polymorphic
+intermediate is manufactured; `LR.CoherentSelfStep.of_leafSteps` (ADQ:6678)
+takes the same; `LR.CoherentSelfStep.of_leafStepsDeep` (ADQ:6690) now takes
+`LR.ConstDefnDeepStepR Γ₀` and goes through
+`LR.ConstDefnDeepInstStep.of_deepStepR`.
+
+No discrepancy against the probe.  `CoherentSeedAt`, `RDeepChildren` and every
+seed transport law are untouched, as probeH's §3 demanded.  **This narrows the
+residual; it does not discharge it.**  What remains still needs the δ-rank
+third well-founded component.
+
+#### Port 2 — the N2 premise change and the four supplying call sites (item 5(i)+(ii))
+
+**Naming, for the record:** the premise replaced is NOT `hcap` (the per-path
+aligned-capture family, unchanged) but the third one — the context-free
+typed-lower-head existential intro'd as `htyped`.  The premortem's own N2
+section names it correctly as the `typedLowerHead` fallback; the tower summary
+above does not.
+
+(i) `LR.FixedHeadResult` (ADQ:2226) and `LR.FixedHeadResultAt` (ADQ:2274):
+binder block `{head : TShape}` → `{head headTy : TShape}`, and
+
+```
+    LE_Interp.RHS.ShapeSpine … head rule.capturePaths out.T →
+    (∃ headElem headTy : TShape, headElem ≤ head ∧ headElem.HasType headTy) →
+```
+became
+```
+    ∀ hshape : LE_Interp.RHS.ShapeSpine … head rule.capturePaths out.T,
+    LR.FixedHeadTelescope (headTy := headTy) (outTy := outTy.T)
+      Γ₀ mx my captureType hshape →
+    LE_Interp.Witness ρ headTy (SExpr.mkInst recLs rule.df.type) →
+```
+
+`headTy` is universally quantified (an existential would need `Nonempty` over
+a `Type`-valued `Witness` — exactly what N2 rejected); the spine premise is
+NAMED so the telescope can be indexed by it, which costs nothing at consumers
+because `FixedHeadTelescope` ignores its `spine` argument definitionally; the
+terminal index is the caller's own `outTy.T`.
+
+The eight Group-B adapters took the predicted two-token edit — insert `headTy`
+after `head` in the `intro`, replace `htyped` by `htel hTyReg`:
+`LR.FixedHeadResult.at` (ADQ:2317), `.of_forall_at` (ADQ:2328),
+`LR.FixedHeadResultAt.mono` (ADQ:2338), `LR.FixedHeadResult.mono` (ADQ:2349),
+`.bot` (ADQ:2360), `.bvar` (ADQ:2377), `.sort` (ADQ:2393),
+`LR.FixedHeadResultAt.of_le` (ADQ:4759).  `.sort` was the one the probe had
+NOT re-proved (verified by inspection only); it elaborated unchanged, so the
+inspection was right.
+
+A single-file `lake env lean` check after (i) alone produced EXACTLY four
+errors, all "argument `htyped` has type `∃ headElem headTy, …` but is expected
+to have type `LR.FixedHeadTelescope …`", at the four Group-C sites and nowhere
+else.  That is the machine confirmation of the queue doc's "10 declarations,
+zero new obligations" claim, and of the claim that the
+`IotaRHSDefEq.of_nonbot` / `of_nonbotWitness` / `of_nonbotWitnessResult`
+family (ADQ:2638 / 2701 / 2754) needs no edit at all: those keep the old
+existential in their own callback contract, and the new evidence enters from
+the enclosing theorem.  That is what bounds the ripple.
+
+(ii) The producer interface landed as `LR.FixedHeadProducer` (ADQ:2574),
+verbatim from probeF — continuation-passing, delivering the telescope and the
+registered-type witness at ONE index at `outTy.T`.  The four Group-C sites each
+gained a `producer` hypothesis and thread it through:
+
+- `LRS.iotaDefEq_of_ctorExactAt_fixedHead` (ADQ:3221), producer at `ρ`;
+- `LRS.iotaDefEq_of_ctorExactAt_closedFixedHead` (ADQ:3297), producer at
+  `Valuation.nil`;
+- `LRS.iotaDefEq_of_ctorExactAt_natStep` (ADQ:4997), inherits the nil-valuation
+  producer and passes it straight down;
+- `LRS.iotaDefEq_of_ctorExactAt_coherent` (ADQ:5056), producer at `ρ`.
+
+Body shape at each: `refine producer rule mx my captureType hshape
+(outTyP := outTy) ?_; intro headTy htel hTyReg; <old application with
+htyped ↦ htel hTyReg>`.  At `_coherent` the single `refine` is placed before
+`cases hseed`, so both the all-depth and the local branch share one
+elimination.  The now-unused callback binder is renamed `_htyped` at all four
+sites; no linter warning was added or removed anywhere in the file.
+
+**Two deviations from the probe, both forced and both small.**
+
+1. probeF states `FixedHeadProducer` at ONE instantiation (`leaf_call`).  A
+   call site needs it quantified, so the landed hypothesis is
+   `∀ (rule : Pattern.IotaRule r) {head} (mx my captureType) {outTyP}
+   (hshape …), LR.FixedHeadProducer Γ₀ ρ rule mx my captureType hshape
+   (recLs := recLs) (outTy := outTyP)`.  `recLs` and `outTy` MUST be passed by
+   name: neither is determined by `hshape` — `recLs` occurs only under
+   `SExpr.mkInst recLs rule.df.type` in the body, and `outTy` only in the
+   telescope's terminal index.  `mx my captureType` are explicit for the same
+   reason (they are explicit in `FixedHeadProducer` itself).
+2. The predicted `_closedFixedHead` side condition arrived exactly as
+   diagnosed: the consumer is pinned to `Valuation.nil`, `Witness.closedAt`
+   needs `(mkInst recLs rule.df.type).ClosedN`, and `Pattern.IotaRule` carries
+   `rhsClosed` but no `typeClosed`.  Resolved the cheap way — that site's
+   producer is stated at `Valuation.nil` directly.  **No field was added to
+   `Pattern.IotaRule`**; `SExpr.lean` is untouched and no fixture source needs
+   an edit.  The cost is recorded, not paid: whoever discharges the
+   nil-valuation producer will have to obtain the registered type's closedness
+   from somewhere, and `rhsClosed` will not give it to them.
+
+#### Port 3 — the ordered producer (item 5(iii))
+
+Ported verbatim from probeF §2 under the queue doc's suggested names:
+
+- `LR.FixedHeadOrderedLink` (ADQ:2467) — the per-layer input, in
+  continuation-passing form so `argCap` and the argument witness stay
+  proof-relevant.  The equation `headTy = (WShape.forallE tyDom tyFun).T` IS
+  the capture-domain link.  `B = .forallE Bdom Bbody` is a layer datum, not
+  derived (O3: `PathSpineWF` reaches the syntactic Pi form only through
+  `conv`/`ret` edges carrying bare `IsDefEq`).
+- `LR.FixedHeadTerminalLink` (ADQ:2492) — the terminal input, carrying O1 in
+  its docstring.
+- `LR.FixedHeadTelescope.consPeel` (ADQ:2503, probeF's `consPeel`) — the layer
+  step, returning the telescope layer AND the peeled witness from one
+  declaration so a caller cannot pair a layer with a witness peeled at another
+  domain.  This is the file's first `noncomputable def`.
+- `LR.FixedHeadTelescope.ofOrderedLink` (ADQ:2538, probeF's
+  `telescope_ofOrderedLink`) — the ordered recursion, 12 lines.  The producer
+  is the coincidence that `FixedHeadTelescope.cons` demands its tail at
+  `(tyFun.app argCap).T` and `LE_Interp.Witness.forallE_inst` delivers the next
+  registered-type witness at exactly that observation.
+
+No bridge from `ofOrderedLink` to `FixedHeadProducer` was attempted, and none
+should be: by O1, `WithCaptures.nil` forces `headTy = outTy` as an index
+equality, so the telescope's terminal index is the codomain observation the
+peel actually reaches, while the premise pins it to the caller's `outTy.T`.
+A leaf-local `TerminalLink` is therefore stronger than any leaf can discharge;
+the repair is producer-side, at the `constDefEq`/`Matches` materialization
+boundary, where `hout`/`hA` must be produced BY the ordered peel rather than
+supplied beside it.  O2 (no level-reconciliation constructor on
+`WithCaptures`; the caller-side `ShapeSpine` head-lift is the clean repair, and
+is a non-empty-spine lemma only) is likewise untouched.
+
+#### State of the tower after this session
+
+`LR.iotaWitnessStep` (ADQ:7434, `sorry` at ADQ:7464) remains the file's ONLY
+`sorry`; the warning profile is byte-identical modulo line shifts.  Remaining
+named obligations, in the order the assembly needs them:
+
+1. `LRS.CtorSpineTypeUniqPath` — unchanged, environment-level, not reachable
+   from a depth-bounded rung.
+2. `LR.CoherentIotaLeafStep Γ₀` — unchanged.
+3. The δ-definition residual — now `LR.ConstDefnDeepStepR` /
+   `LR.ConstDefnDeepInstStep` rather than `LR.ConstDefnDeepStep`.  Both
+   erasures are repaired; what is left is genuinely the δ-rank component.
+4. `LR.CoherentFixedHeadStep Γ₀` (ADQ:4939) — step (iv), NOT attempted, per the
+   queue doc's landing order.  It is now materially closer: its conclusion is
+   `LR.FixedHeadResultAt Γ₀ hX depth`, whose changed premise hands it the
+   telescope and the registered-type witness at one index, and it already
+   receives `LR.SelfAdequateAt Γ₀ hX depth` at the same witness and depth — so
+   the head-validity half is a direct application of
+   `LR.SelfAdequateAt.of_fixedHeadTelescope` (ADQ:4165) with no global
+   `AdequacyAtDepth`.  The application-fold half still routes through
+   `LR.FixedHeadTelescope.toApplicationWithAdequacyAtDepth` (ADQ:2188), which
+   takes `LR.AdequacyAtDepth Γ₀ depth` plus the `convert` callback and the two
+   closedness facts.  That input, not the premise, is now the wall.
+5. Assembly: `LR.CoherentRetainedNatStep.of_steps` (ADQ:4952) from
+   `CoherentSelfStep.of_leafStepsDeep` (ADQ:6690) + item 4.
+
+The four Group-C `producer` hypotheses are the new explicit obligations
+introduced by this session.  They are leaf-local statements of a producer-side
+fact (O1), so the next design pass on them should start at the
+materialization boundary, not at the leaf.
+
+**Build note for the fixture slice:** this session changed only
+`ShapeLogRelAdequacy.lean` and rebuilt only
+`Lean4Lean.Experimental.ShapeLogRelAdequacy`.  The D0/D1/D2 fixture oleans
+(`SExprParamsD0/D1/D2`) are stale by design and need the central rebuild before
+they are trusted again.  Unlike the previous session's change this one is NOT
+purely additive — `FixedHeadResult`/`FixedHeadResultAt` changed a premise and
+four `iotaDefEq_of_ctorExactAt_*` theorems gained a hypothesis — but every
+affected declaration lives in `ShapeLogRelAdequacy.lean` and every in-file
+consumer was updated, so no fixture source edit is expected either.
+
+— session-C subagent 7
+
+### `CoherentFixedHeadStep` lands; the application fold's adequacy demand is at `depth - 1`, not at the rung (2026-08-15, session-C subagent 8)
+
+Item 4 of the tower is proved.  `LR.CoherentFixedHeadStep.of_steps`
+(ADQ:5227) is green, conditional on two named Props and on nothing else — in
+particular on no global `LR.AdequacyAtDepth` at the rung, which is what the
+previous session recorded as "the wall".  Final state of
+`ShapeLogRelAdequacy.lean`: **zero errors**, the same sole `sorry` at
+`LR.iotaWitnessStep` (now ADQ:7718:8, token ADQ:7748), and 87 → 90 warnings,
+the three new ones being the `unusedSectionVars` linter firing on the three
+new declarations that do not use `[Params.Semantic]`.  Every other warning is
+byte-identical modulo line shifts (`diff` of the sorted, line-stripped sets is
+empty apart from those three additions).  `ShapeLogRel.lean` and `SExpr.lean`
+were not touched.
+
+#### THE DEPTH ANSWER (the paragraph that matters)
+
+**The application fold does not need same-rung adequacy.  Its demand splits
+into one call the step already holds and one call at `depth - 1`.**
+
+`LR.FixedHeadTelescope.toApplicationWithAdequacyAtDepth` (now ADQ:2281)
+takes `LR.AdequacyAtDepth Γ₀ depth` at literally the same `depth` as
+its `hstrat : HasTypeStratifiedS Δ X headType core depth`, and
+`LR.FixedHeadResultAt Γ₀ hX depth` supplies `hstrat` at exactly the rung's
+depth — so read off the signatures, the answer is "same rung, G4 fires".  That
+reading is wrong, and the reason is visible only one level down, inside
+`LR.AdequacyAtDepth.closedHeadSelf` (ADQ:2098), which is where the single
+`adequacy` hypothesis is actually spent.  It is spent **twice, at two
+different subjects and two different depths**:
+
+1. `adequacy hstrong hstrat hX.toInterp hTy.toInterp htyped` — subject `X`,
+   displayed type `headType`, certificate at `depth`.  This instance is
+   *pointwise identical* to an instance of `LR.SelfAdequateAt Γ₀ hX depth`:
+   both conclude `LR.Adequate Γ₀ Δ ρ X X headType headElem headElemTy`, and
+   `SelfAdequateAt`'s only extra premise is `headElem.T ≤ root`, which the
+   `headSelf` callback supplies as `headElem.T ≤ head` composed with the
+   fold's own `hhead : head ≤ root`.  `LR.CoherentRetainedNatStep.of_steps`
+   (ADQ:5199) hands `CoherentFixedHeadStep` exactly that package at exactly
+   that witness and depth.  **Cost: zero.**
+2. `adequacy hTypeStrong (hTypeStrat.mono (Nat.sub_le depth 1)) …` — subject
+   `headType`, displayed type `.sort u`.  `HasTypeStratifiedS.isType`
+   (SExpr:2716) returns `∃ u, Γ ⊢ A : .sort u !! n - 1`, so this certificate
+   lives at `depth - 1`; the `mono` exists **only** so that one hypothesis can
+   serve both calls.  Drop the `mono` and the honest demand is
+   `LR.AdequacyAtDepth Γ₀ (depth - 1)`.
+
+So the arithmetic is: rung `depth`, term call at `depth`, type call at
+`depth - 1`.  `depth - 1 < depth` iff `0 < depth`; at `depth = 0` truncated
+subtraction collapses the two, which is why
+`LR.FixedHeadTypeValidStep.of_lowerAdequacy` (ADQ:2200) carries an explicit
+`0 < depth` and `of_predecessorAdequacy` (ADQ:2169) does not.  The depth-zero
+rung is the only place the demand stops being a predecessor demand.
+
+Two consequences must be stated together, or the result will be over-read.
+
+*The G4 tripwire does not fire on the step.*  Nothing is manufactured inside
+the induction: the term half arrives through the step interface, and the type
+half is an interface hypothesis of `of_steps`.  Neither `children` nor the
+strict predecessor family `lower` is consumed at all — the fixed-head half
+turns out to need **no recursion whatsoever** once the N2 premise change hands
+it the telescope.  That is the strongest evidence yet that the N2 decision was
+the right one.
+
+*But the predecessor family that would discharge the type half is not the one
+the step carries.*  `CoherentFixedHeadStep`'s `lower` is a family of
+`LR.CoherentRetainedAt Γ₀ hX' d'`, not of `LR.AdequacyAtDepth Γ₀ d'`; and its
+`depth` is the **inner** Nat index of the coherent witness recursion,
+universally quantified, with no relation to the **outer** adequacy rung `d` of
+`LR.IotaWitnessStepAtDepth` (ADQ:1880) whose family
+`contextualAdequacyAtDepth_of_iotaSteps` (ADQ:7681) forwards.  Worse,
+the inner `depth` here is the stratification depth of a *registered
+declaration's own typing* (`Pattern.IotaRule.rhsStrong`, SExpr:2242) — an
+environment-level quantity, exactly like `LRS.CtorSpineTypeUniqPath` — so it
+is not bounded by the outer rung and `∀ depth, FixedHeadTypeValidStep Γ₀
+depth` is not reachable from `∀ d' < d, ContextualAdequacyAtDepth d'`.  That
+is why the obligation is landed as a named Prop quantified over all inner
+depths, in the same idiom `LR.CoherentSelfStep.of_leafSteps` already uses for
+`defeqStep : ∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth`, rather than
+discharged.  The honest summary: **the wall moved from "adequacy at the rung"
+to "type-level adequacy at the predecessor of an environment-fixed depth",
+which is strictly smaller, structurally the same shape as the self-adequacy
+half's existing obligation, and no longer blocks item 4.**
+
+#### What landed
+
+Producers and named obligations, in file order:
+
+- `LR.AdequacyAtDepth.of_le` (ADQ:2132) — contravariance in the depth index;
+  larger index = strictly stronger package.
+- `LR.FixedHeadTypeValidStep Γ₀ depth` (ADQ:2155, NEW OBLIGATION) — the
+  isolated type rung of `closedHeadSelf`.  Discharged by
+  `of_predecessorAdequacy` (ADQ:2169) from `LR.AdequacyAtDepth Γ₀ (depth - 1)`
+  with **no `mono` anywhere**; by `of_adequacyAtDepth` (ADQ:2190) from the old
+  same-rung package (faithfulness); and by `of_lowerAdequacy` (ADQ:2200) from
+  `∀ d < depth, ContextualAdequacyAtDepth d` given `0 < depth`.
+- `LR.FixedHeadConvertStep Γ₀` (ADQ:2215, NEW OBLIGATION, pre-existing in
+  substance) — the conversion transport
+  `IsDefEq Γ₀ A B (.sort u) → TyDefEq A A a → TyDefEq A B a`.  This was always
+  a hypothesis of `LR.FixedHeadTelescope.toApplicationWith`; it is only now
+  named.  It is **not** an instance of
+  `LR.TyDefEq.of_defeq_of_stratifiedInversion` (ADQ:1168): that lemma also
+  demands `TyDefEq B B a`, and the chain zip has no producer for it.  Its
+  shape is fixed by `LR.FixedHeadShapeChain.pathSemantics` (SLR:14322), which
+  is outside this session's territory.
+- `Pattern.IotaRule.typeClosed` (ADQ:2693) — **the recorded
+  `_closedFixedHead` side condition is discharged.**  `Pattern.IotaRule` still
+  has no `typeClosed` field and needs none: `VEnv.Ordered.closed`
+  (Theory/Typing/Lemmas.lean:412) closes all three components of every
+  registered `VDefEq`, so `(Params.henv.closed.2 rule.registered).2.2.mkInstS`
+  is the whole proof.  No `SExpr.lean` edit, no fixture source edit.
+- `LR.FixedHeadTerminalRetarget` (ADQ:2721, NEW OBLIGATION) and
+  `LR.FixedHeadProducer.of_orderedLink` (ADQ:2741) — see the O1 section below.
+- `LR.SelfAdequateAt.closedHeadSelf` (ADQ:4370) — the depth-refined
+  `headSelf` callback: `SelfAdequateAt` at the same witness and depth for the
+  term half, `FixedHeadTypeValidStep` for the type half, both closedness facts
+  free.  Endpoints are the literal ones the packed telescope selected; nothing
+  is re-existentialized (contrast `SelfAdequateAt.of_fixedHeadTelescope`
+  (ADQ:4341), which republishes an existential and is therefore *not*
+  what the fold should call).
+- `LR.FixedHeadTelescope.toApplicationWithSelfAdequacy` (ADQ:4400) — drop-in
+  strengthening of `toApplicationWithAdequacyAtDepth`: same conclusion, same
+  `convert`/`raw`/`resultRel`/closedness inputs, but `AdequacyAtDepth Γ₀
+  depth` replaced by the two weaker inputs above.  The original is kept
+  unused as the reference statement, the same treatment `MajorChainFoldStep`
+  and `ConstDefnLocalStep` received.
+- `LR.CoherentFixedHeadStep.of_steps` (ADQ:5227) — **item 4**.  Twelve lines.
+  `by_cases` on `out.T ≤ TShape.bot` (bottom branch is `FixedHeadResult.bot`'s
+  ending verbatim), then `FixedHeadApplication.applyRule` on
+  `toApplicationWithSelfAdequacy`.  `hX` must be passed by name at both calls:
+  `LR.FixedHeadApplication`'s `depth` and `hX` are phantom indices — neither
+  occurs in its body — so unification cannot recover them.
+
+Three premises of `FixedHeadResultAt` are **not used** by the proof and were
+renamed with a leading underscore: `hstrong` (subsumed by `hstrat`), `hspineY`
+(the fold zips one raw spine), and — the interesting one — `hcap`, the
+existential per-path capture family.  The telescope already carries every
+capture at its own shapes, so the shape-existential form is now dead weight at
+this consumer.  That is the N2 retention paying out exactly as designed.
+
+#### O1 re-diagnosed: the prescribed repair is not available below `LR.Adequate`
+
+The port queue's O1 says the fix is producer-side, "at the `constDefEq`/
+`Matches` materialization boundary, where `hout`/`hA` must be produced BY the
+ordered peel rather than supplied beside it".  **That repair does not exist
+there**, and the reason is a one-line signature fact worth recording so nobody
+spends a session looking for it: `hout`/`hA` are *inputs* of `LR.constDefEq`
+(ADQ:3638).  The fold recomputes them only when it crosses an application
+layer; in its `pat` branch it passes them to the pattern leaf unchanged, and
+`LR.PatternLeafDefEq.of_iota`, `LR.IotaLeafDefEq` and `LRS.IotaRHSDefEq`
+thread them verbatim to `LRS.iotaDefEq_of_ctorExactAt_*`.  So `outTy` is fixed
+by the caller of the constant-evaluation fold — ultimately by the shape
+argument of `LR.Adequate` — before any pattern is matched.  Nothing at or
+below the matched leaf can produce it.
+
+Two further checks, both negative, both recorded so they are not re-derived:
+
+* `Shape.HasType` is **not** functional, so `out` does not determine `outTy`:
+  `Shape.HasTypeU.bot` (SLR:2548) types `.bot` at every `x` with
+  `HasType x .type`, and `.lam`/`.forallE` do not pin their type index either.
+  O1 cannot be dissolved by uniqueness of the observation.
+* Building the telescope bottom-up instead of peeling top-down does not help.
+  `WithCaptures.cons` (SLR:3661) demands its tail at `(tyFun.app argCap).T`
+  and threads `outTy` unchanged, so the same equation reappears at the base:
+  the fully-peeled registered-type observation must *equal* the caller's
+  `outTy`.  There is no `≤` anywhere on that index.
+
+What this leaves is one equation, and it is now named:
+`LR.FixedHeadTerminalRetarget Γ₀ mx my captureType spine outTy` (ADQ:2721)
+reads a finished telescope at the caller's result observation instead of the
+peel's.  With it, `LR.FixedHeadProducer.of_orderedLink` (ADQ:2741) discharges
+the whole `FixedHeadProducer` interface from four inputs: the registered
+type's own observation `hTyReg`, `FixedHeadOrderedLink`,
+`FixedHeadTerminalLink`, and the retarget.  So the four leaf-local `producer`
+hypotheses introduced by the previous session are no longer opaque: they are
+one reusable producer plus three named per-shape Props.  The retarget's
+natural producer is a *uniqueness* statement rather than a construction — the
+peel's terminal witness observes the syntactic spine result `A` (the right
+endpoint of `SExpr.PathSpineWF`), and the caller's
+`hA : (LR Γ₀).TyDefEq A A outTy` observes that same `A` at `outTy`.  A
+terminal-index monotonicity for `WithCaptures` would also do it, but that is a
+`ShapeLogRel.lean` change and was therefore not attempted.
+
+#### Remaining tower (updated)
+
+1. `LRS.CtorSpineTypeUniqPath` — unchanged; environment-level, not reachable
+   from a depth-bounded rung.
+2. `LR.CoherentIotaLeafStep Γ₀` — unchanged; item 1 plus the multi-level frame
+   layer whose shape-threading specification is in subagent 6's entry.
+3. The δ-definition residual (`LR.ConstDefnDeepStepR` /
+   `LR.ConstDefnDeepInstStep`) — unchanged; genuinely the δ-rank component.
+4. **`LR.CoherentFixedHeadStep Γ₀` — DONE** (ADQ:5227), conditional on
+   `LR.FixedHeadConvertStep Γ₀` and `∀ depth, LR.FixedHeadTypeValidStep Γ₀
+   depth`.
+5. `LR.FixedHeadConvertStep Γ₀` (NEW, ADQ:2215) — one-sided conversion
+   transport for `TyDefEq`; needs the right endpoint's validity, which the
+   chain zip does not carry.  Not new work created by this session: it has
+   been a hypothesis of `toApplicationWith` since that lemma existed.
+6. `∀ depth, LR.FixedHeadTypeValidStep Γ₀ depth` (NEW, ADQ:2155) —
+   type-level adequacy at `depth - 1`; same interface idiom as
+   `∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth`, which
+   `CoherentSelfStep.of_leafSteps` already takes, so these two should be
+   discharged together by whatever eventually supplies the depth family.
+7. `LR.FixedHeadTerminalRetarget` (NEW, ADQ:2721) — the isolated O1 equation;
+   with `FixedHeadOrderedLink` and `FixedHeadTerminalLink` it discharges all
+   four `producer` hypotheses via `FixedHeadProducer.of_orderedLink`.
+8. Assembly: `LR.CoherentRetainedNatStep.of_steps` (ADQ:5199) now needs only
+   `CoherentSelfStep.of_leafStepsDeep` plus item 4 — i.e. the fixed-head half
+   is no longer what blocks it.
+
+**Build note for the fixture slice:** this session changed only
+`ShapeLogRelAdequacy.lean` and rebuilt only
+`Lean4Lean.Experimental.ShapeLogRelAdequacy` (`lake build`, exit 0, "Build
+completed successfully (34 jobs)").  The change is **purely additive** — no
+existing declaration changed its statement, gained a premise, or was removed;
+`toApplicationWithAdequacyAtDepth` and `AdequacyAtDepth.closedHeadSelf` are
+kept verbatim as reference statements.  The D0/D1/D2 fixture oleans
+(`SExprParamsD0/D1/D2`) remain stale by design from the previous two sessions
+and still need the central rebuild; no fixture source edit is expected from
+this session either.
+
+— session-C subagent 8
+
+### The `∀ depth` type rung is discharged from `lower`; O1 is refuted (2026-08-15, session-C subagent 9)
+
+`ShapeLogRelAdequacy.lean`: **zero errors**, `Build completed successfully
+(34 jobs)`, the same sole `sorry` at `LR.iotaWitnessStep` (now ADQ:7936:8,
+token ADQ:7968), and the warning set is **byte-identical to the baseline** —
+90 before, 90 after, `comm` empty in both directions after stripping line
+numbers.  Not "changed only by `unusedSectionVars`": *unchanged*.  The eight
+new declarations all forward `[Params.Semantic]` into an existing lemma that
+carries it, so the linter does not fire on any of them.  `ShapeLogRel.lean`
+and `SExpr.lean` were not touched.
+
+#### THE DEPTH AUDIT (lead with this; it decided the session)
+
+**At which depths is `∀ depth, LR.FixedHeadTypeValidStep Γ₀ depth`
+instantiated on the leaf path, and are those depths bounded by the rung?**
+
+*Instantiated at every `depth : Nat`.  Not bounded by the rung.  Neither
+branch of the audit's dichotomy applies, because the dichotomy's premise —
+that the only producer is adequacy at `depth - 1` — is false.*
+
+The two indices, kept apart:
+
+* the **outer rung** `d` of `LR.IotaWitnessStepAtDepth Γ₀ d` (ADQ:1880),
+  which forwards `∀ d' < d, ContextualAdequacyAtDepth d'`.  Note that its
+  product `LR.IotaWitnessStep` (ADQ:1860) is itself **depth-free**;
+* the **inner Nat index** `depth` of the coherent witness recursion.
+  `LR.CoherentRetainedResult` (ADQ:4500) is *literally* `∀ depth,
+  CoherentRetainedAt Γ₀ hX depth`, so `recRDeepNatProvenance` fires the step
+  at every Nat.  `LR.CoherentFixedHeadStep` therefore quantifies `depth`
+  universally and `of_steps` consumed `typeValid depth` at that same index.
+
+Not bounded, for two independent reasons, both now confirmed against the
+source rather than inferred:
+
+1. The bootstrap withholds the bound *by design*.
+   `contextualAdequacyAtDepth_of_iotaSteps`'s docstring (ADQ:7676-7680):
+   "the derivation induction is depth-blind, so a root certificate cannot
+   bound the leaf instances reached through `trans` or evaluator descent.
+   Whatever depth bound a leaf producer needs must come from its own
+   registered-rule certificates."
+2. The registered-rule certificates do **not** supply it here, and this is
+   where the `rootRed` pattern fails to transfer.  The candidate was
+   `Pattern.IotaRule.FocusedActionPreimage` (SLR:9278-9290), whose
+   `rhsStratified` sits at `rhsDepth` and whose `headStratified` sits at
+   `rhsDepth - rule.capturePaths.length` — a genuine bound, but on a
+   *different* certificate than the one the fixed-head consumer reads.  The
+   two live instantiations are `LRS.iotaDefEq_of_ctorExactAt_coherent`
+   (ADQ:5416), which takes its depth from
+   `obtain ⟨rhsDepth, hstrat, _⟩ := hstrong.stratify` on `rule.rhsStrong` —
+   an unbounded existential on an environment-level derivation — and
+   ADQ:5420, which takes the ambient `CoherentRhsSeedAt` depth.  Neither
+   reads `headStratified`.
+
+**So both audit branches fail, and it is still not a G4 tripwire.**  The
+third producer is inside the step's own interface:
+
+> `∀ depth` never needed to be bounded.  The obligation at each `depth` is
+> dischargeable from `lower` — `LR.CoherentFixedHeadStep`'s own strict
+> predecessor family — at that same `depth`.
+
+The arithmetic, spelled out:
+
+| piece | index | source |
+|---|---|---|
+| term half | `depth` | `hself : SelfAdequateAt Γ₀ hX depth`, an interface input (subagent 8) |
+| type half | `depth - 1` | `HasTypeStratifiedS.isType` (SExpr:2716) |
+| decrease | `depth - 1 < depth ⟺ 0 < depth` | `Nat.sub_lt` |
+| `0 < depth` | — | `LR.CoherentRetainedAt.restart lower (Nat.sub_lt hdepth Nat.one_pos)` at `hTypeInterp.witness` |
+| `depth = 0` | — | no adequacy at all; see below |
+
+Two facts make the restart legal here, and both are specific to this
+obligation:
+
+* **The witness is unrelated to `hX`.**  The type half needs self-adequacy at
+  the *registered type's own* interpretation witness, which is not a child of
+  the fixed head's witness — `children` could never have supplied it.
+  `LR.CoherentRetainedAt.restart` (ADQ:5030) admits an arbitrary witness
+  precisely because it rebuilds the evaluator tree itself via
+  `LR.CoherentSeedAt.rebuild`.  This is the same move
+  `LR.selfAdequateExactAtStep` already makes at ADQ:6299-6304 (`restartSelf`).
+* **The conclusion is homogeneous.**  `CoherentRetainedAt` carries
+  `SelfAdequateAt Γ₀ hX' d'`, i.e. `Adequate Γ₀ Δ ρ X X B mx bx` with *one*
+  subject; `FixedHeadTypeValidStep`'s conclusion is
+  `TyDefEq headType headType headElemTy`, also homogeneous, so it fits
+  exactly.
+
+`depth = 0` is free, not residual.  Every `HasTypeStratifiedS` constructor
+except `sort'` and `base` carries the index `n + 1` (SExpr:2380-2409), so a
+depth-`0` certificate forces `X = .sort l` and `headType = .sort l.succ`;
+the conclusion is then the `sort_iff` / `bot` split already used by the
+`sort'` case of `selfAdequateExactAtStep`.  Machine-checked as
+`LR.FixedHeadTypeValidStep.zero`.
+
+#### The previous session's "discharge both together" recommendation is REFUTED
+
+`∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth` has the same `∀ depth` shape
+but **cannot** take this route, and the reason is one word: heterogeneity.
+`SelfAdequateDefeqStepAt.of_lowerAdequacy` (ADQ:6231-6241) feeds
+`LR.adequateDefeq`'s first callback, whose type (ADQ:4343-4355, `ihTy`) is
+`Adequate Γ₀ Γ ρ A B (.sort u) ma sa` — **two different endpoints**, carrying
+the `A ≡ B` link.  `SelfAdequateAt` produces only `X X`, so the coherent
+predecessor family is strictly too weak.  Whatever eventually supplies that
+family must either be genuinely heterogeneous adequacy at unbounded inner
+depths, or `LR.CoherentRetainedAt` must be widened to carry a heterogeneous
+rung — and the second is not free, since `selfAdequateExactAtStep` inducts on
+the stratified typing of the *witness's own* subject and has no second
+subject to offer.
+
+#### What landed
+
+- `LR.FixedHeadTypeValidStep.of_lowerCoherent` (ADQ:4987) — the discharge at
+  `0 < depth`, from `lower` alone.  No `LR.AdequacyAtDepth` at any rung.
+- `LR.FixedHeadTypeValidStep.zero` (ADQ:5021) — the depth-zero rung.
+- `LR.FixedHeadTypeValidStep.of_coherentLower` (ADQ:5054) — the two combined;
+  this is what removes the obligation.
+- `LR.CoherentFixedHeadStep.of_convertStep` (ADQ:5445) — **item 4 with the
+  type family gone**.  Identical to `of_steps` (ADQ:5412, kept unchanged as
+  the reference statement) except that `typeValid` is no longer a hypothesis:
+  the instance is built from `lower`, which `of_steps` left unused.  Its only
+  remaining input is `LR.FixedHeadConvertStep Γ₀`.
+- `LR.FixedHeadConvertRightValid` (ADQ:2240) + `LR.FixedHeadConvertStep.of_rightValid`
+  (ADQ:2249) — target 2 narrowed.  The recorded dead end
+  (`LR.TyDefEq.of_defeq_of_stratifiedInversion` "also demands
+  `TyDefEq B B a`") is turned into a producer by *naming* that demand.  The
+  residual is then readable by unfolding: at `a = .sort r`, `sort_iff_ty`
+  makes it "`B` has a weak-head normal form and it is a sort"; at
+  `a = .forallE b f` the same with Pi.  That is `PiHeadNorm` =
+  `TypeWHNFEx` + `PiHeadStable`, the single irreducible factor probeP
+  isolated inside `PiPathInv`.  Nothing weaker is available at the consumer:
+  `SExpr.PathSpineWF`'s `conv`/`ret` edges (SExpr:1650-1658) carry a bare
+  `IsDefEq` and no shape, witness, or endpoint validity — G5 in its exact
+  position.  (Also checked and rejected: `SExpr.IsDefEq.strong`
+  (SExpr:3013) is a real proved bridge, but it only upgrades the raw edge;
+  it produces no interpretation of `B` at `a`, so it does not help.)
+- `LR.FixedHeadTerminalRetarget.hasType_functional` (ADQ:2777) and
+  `LR.FixedHeadTerminalRetarget.not_general` (ADQ:2804) — see below.
+
+Probes (untracked, both green, exit 0, no `sorryAx`):
+`plans/probes/probeT-typevalid.lean` (3 results, axioms
+`propext, Classical.choice, Quot.sound` only) and
+`plans/probes/probeU-convert-retarget.lean` (3 results).
+
+#### O1 RESOLVED IN THE NEGATIVE: `LR.FixedHeadTerminalRetarget` is FALSE
+
+Not "hard", not "needs a producer" — **refutable**, and now machine-checked.
+
+`WithCaptures.nil` (SLR:3661) identifies the telescope's two type indices, so
+at a nil-terminated spine the retarget says exactly: every type of `head`
+equals the caller's `outTy`.  `LR.FixedHeadTerminalRetarget.hasType_functional`
+proves that implication; `TShape.HasType.bot` (SLR:3135) types `.bot` at every
+sort, so `not_general` derives `False` from the Prop at
+`head := TShape.bot`.  `WithCaptures.cons` threads `outTy` unchanged, so on a
+longer spine the same demand simply reappears at the base — the refutation is
+not an artefact of the empty spine, it is the base case of every spine.
+
+Consequences, so the next session does not re-plan around a false statement:
+
+* the previous session's suggested producer — "a *uniqueness* statement rather
+  than a construction", using the caller's `hA : TyDefEq A A outTy` — is
+  refuted along with the Prop.  There is nothing to produce.
+* `LR.FixedHeadProducer.of_orderedLink` (ADQ:2874) is therefore conditional on
+  a false hypothesis.  It is left in place (it is not *wrong*, just vacuous),
+  but it must not be counted as progress toward the four leaf `producer`
+  hypotheses.
+* the repair cannot be leaf-side or producer-side at all.  Two routes remain,
+  both requiring `ShapeLogRel.lean`, i.e. outside this session's territory:
+  (i) give `TypedTelescope.WithCaptures` a terminal-index monotonicity — the
+  same absence O2 records for its level index; or (ii) let
+  `LR.FixedHeadShapeChain.pathSemantics` (SLR:14322) consume a chain at the
+  observation the peel actually reached plus a semantic bridge to `outTy`, so
+  the caller's `hout`/`hA` are used where they are in fact available.  Route
+  (ii) is the one consistent with subagent 8's signature finding that
+  `hout`/`hA` are *inputs* of `LR.constDefEq`.
+
+#### Remaining tower (updated)
+
+1. `LRS.CtorSpineTypeUniqPath` — unchanged; environment-level.
+2. `LR.CoherentIotaLeafStep Γ₀` — unchanged.
+3. δ-definition residual (`LR.ConstDefnDeepStepR` / `LR.ConstDefnDeepInstStep`)
+   — unchanged; the δ-rank component (probeK).
+4. `LR.CoherentFixedHeadStep Γ₀` — **DONE, and now conditional on
+   `LR.FixedHeadConvertStep Γ₀` ALONE** (ADQ:5445).
+5. `LR.FixedHeadConvertStep Γ₀` — narrowed to `JointStratifiedInversion` +
+   `LR.FixedHeadConvertRightValid`; the residual is `PiHeadNorm`.  **Blocked
+   on the same irreducible factor as `PiPathInv`.**
+6. ~~`∀ depth, LR.FixedHeadTypeValidStep Γ₀ depth`~~ — **REMOVED, discharged.**
+7. ~~`LR.FixedHeadTerminalRetarget`~~ — **REMOVED, refuted.**  Replaced by a
+   `ShapeLogRel.lean`-side repair request (routes (i)/(ii) above).
+8. `∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth` — unchanged, and now known
+   *not* to be dischargeable alongside item 6.  Blocked on `PiPathInv` via
+   `of_stratifiedInversion`, or on the inner/outer depth mismatch via
+   `of_lowerAdequacy`.
+9. Assembly: `LR.CoherentRetainedNatStep.of_steps` (ADQ:5384) now needs only
+   `CoherentSelfStep.of_leafStepsDeep` plus item 4.
+
+**Build note for the fixture slice:** only `ShapeLogRelAdequacy.lean` changed,
+and only `Lean4Lean.Experimental.ShapeLogRelAdequacy` was built.  The change is
+purely additive — no existing declaration changed its statement, gained or lost
+a premise, or was removed; `of_steps`, `toApplicationWithAdequacyAtDepth`,
+`AdequacyAtDepth.closedHeadSelf`, `of_predecessorAdequacy`, `of_lowerAdequacy`
+and `FixedHeadTerminalRetarget` itself are all kept verbatim.  The D0/D1/D2
+fixture oleans (`SExprParamsD0/D1/D2`) remain stale by design from the previous
+three sessions and still need the central rebuild; no fixture source edit is
+expected from this session either.
+
+— session-C subagent 9
+
+### O1 repaired by terminal-index monotonicity; a SECOND vacuity found and machine-checked (2026-08-15, session-C subagent 10)
+
+`ShapeLogRel.lean`: **zero errors, zero sorries**, warning set **byte-identical**
+to baseline (23 → 23, `diff` empty).  `ShapeLogRelAdequacy.lean`: **zero
+errors**, the same sole `sorry` at `LR.iotaWitnessStep` (ADQ:8348, token
+ADQ:8378), 90 → 100 warnings — nine new `unusedSectionVars` on nine new
+theorems, plus one new `unusedVariables` on `spine`, which is the exact mirror
+of the pre-existing warning on `LR.FixedHeadTelescope` (ADQ:1904) and has the
+same cause: the `spine` argument is ignored definitionally, by design.  No
+warning disappeared.  `SExpr.lean` untouched.  No new `sorryAx`: every new
+declaration checks with `propext, Classical.choice, Quot.sound` only (the two
+`SpineWF` ports need only `propext, Quot.sound`).
+
+#### LEAD WITH THIS: `LR.FixedHeadTerminalLink` IS ALSO FALSE
+
+`LR.FixedHeadProducer.of_orderedLink` was vacuous for **two** independent
+reasons, not one.  Beside the refuted retarget, its `term` input
+
+```
+LR.FixedHeadTerminalLink ρ out := ∀ headTy B, Witness ρ headTy B → out.HasType headTy
+```
+
+is refutable at every non-bottom `out`.  `LE_Interp.Witness.bot` (SLR:3928) is
+`Witness ρ (WShape.T .bot) M` for **arbitrary** `ρ`, `M`, `n`, so instantiating
+at `TShape.bot` gives `out.HasType TShape.bot`, and `TShape.HasType.bot_r`
+(SLR:3120) turns that into `out ≤ TShape.bot`.  Every consumer of the
+fixed-head fold carries `houtNonbot : ¬out.T ≤ TShape.bot` — the bottom result
+shape is split off before the telescope is ever read — so the Prop is false
+exactly where it would be used.  Machine-checked as
+`LR.FixedHeadTerminalLink.le_bot` (ADQ:2844) and `.not_nonbot` (ADQ:2855).
+
+**The pattern behind both refutations, stated so it is not repeated.**  The
+observation lattice has a bottom that *every* syntax is witnessed at and that
+*every* type of type-kind types.  Therefore **no terminal fact about the peel
+may be stated as a law quantified over observations.**  `TerminalRetarget`
+quantified over the reached index; `TerminalLink` quantified over the
+witnessed index; both die to the same instance.  A terminal fact must be a
+*datum at the observation actually reached*, i.e. existential /
+continuation-passing in that index.  That single criterion is what selected
+the route below, and it is the cheap vacuity test to run on the next such
+Prop: instantiate at `TShape.bot` and see whether the statement survives.
+
+#### ROUTE DECISION: (R-A), and (R-B) is not available
+
+**(R-B) is refuted by a signature fact.**  `LR.FixedHeadShapeChain`'s terminal
+index is not free to be the reached observation: it is a `WShape outLevel` that
+flows *verbatim* into `LR.FixedHeadApplication` (ADQ:2075) and thence into the
+conclusion of `LR.FixedHeadResult`, `(LR Γ₀).DefEq … A out outTy`.  Moreover
+`pathSemantics`'s `resultRel : TyDefEq resultType resultType outTy` **is** the
+caller's `hA`, already consumed at the caller's own `outTy`.  So the chain
+must end at `outTy`, the semantic bridge is already there, and there is nothing
+for a second bridge to do.  Recorded as a dead end in
+`FixedHeadTerminalRetarget.not_general`'s docstring.
+
+**(R-A) landed, additive, as a parallel structure.**  The audit that decided
+it: the telescope's terminal index is read in exactly **two** places downstream,
+and both are monotone.
+
+| read | who | direction |
+|---|---|---|
+| `out.HasType outTy` | `WithCaptures.outHasType`, the fold's `nil` case | the caller already holds this (`hout`) |
+| `headElemTy.T ≤ headTy` | the fold's return, spent by `hTy.mono` in `withWitnessAndChain` | head index is an **upper bound** only |
+
+Nothing anywhere uses the head index as a lower bound or as an exact value.
+Hence weakening the base from an index *equality* to `outTy ≤ headTy` is sound
+for every consumer, and it is the unique place the equality was doing work:
+`cons` is verbatim in the new structure, so every layer is the same layer.
+
+#### The new named Prop, and its vacuity check
+
+`LR.FixedHeadTerminalDominance Γ₀ mx my captureType spine headTy outTy`
+(ADQ:3160) — continuation-passing: *some* run of the ordered peel terminates at
+a `reachedTy` with `outTy ≤ reachedTy`, delivering the telescope there.
+
+* **Not refutable by the bot argument**, because the reached observation is
+  chosen by the producer rather than quantified over.  (Contrast: both refuted
+  Props are ∀-over-observations.)
+* **Strictly weaker than what it replaces** — `.of_exact` (ADQ:3174) builds it
+  from the old exact demand at `TShape.LE.rfl`, so nothing that used to
+  discharge the producer stops discharging it.
+* **Inhabited, at the very instance where the retarget is FALSE** — `.nil`
+  (ADQ:3189) builds it at the empty capture spine from `head.HasType outTy`
+  alone, including at `head = .bot`, which is exactly where
+  `FixedHeadTerminalRetarget.not_general` derives `False`.
+
+#### What landed
+
+`ShapeLogRel.lean` (all additive; every pre-existing statement byte-identical):
+
+- `…TypedTelescope.WithCapturesLE` (SLR:3871) — the packed telescope with a
+  monotone terminal index.  Only `nil` differs: `(htyped : head.HasType outTy)`
+  `(hle : outTy ≤ headTy)` in place of the two-index identification.
+- `WithCaptures.toLE` (SLR:3892) — faithfulness.
+- `WithCaptures.retarget` (SLR:3914) — **THE TERMINAL-INDEX MONOTONICITY.**
+  Rebuilds an exact telescope at any lower result observation the caller can
+  type.  This is the lemma `WithCaptures` cannot have on its own.
+- `WithCapturesLE.spine` / `.outHasType` / `.lowerHead` (SLR:3929/3942/3956) —
+  the eliminations, proved directly rather than through `TypedTelescope`, so
+  `TypedTelescope` and `Captures` are untouched.
+- `WithCapturesLE.fixedHeadShapeChain` (SLR:13904) — the fold, differing from
+  the old proof **only in its `nil` case**;
+  `TypedTelescope.fixedHeadShapeChain` (SLR:14110) is kept with its statement
+  byte-identical and is now a one-line corollary via `toLE`, so its sole
+  consumer is unaffected.
+- Secondary ports from `plans/probes/probeS-spinedepth.lean`:
+  `SpineWF.ret_path` (SLR:11360, the missing `ret` dual of `conv_path`) and
+  `HasTypeStratifiedS.spineWF_of_foldl_bound` (SLR:11416), which sharpens the
+  walk to `m + es.length ≤ n`; the old `spineWF_of_foldl` (SLR:11437) keeps its
+  statement and is now a corollary, so its two consumers are unaffected.
+
+`ShapeLogRelAdequacy.lean`:
+
+- `LR.FixedHeadTelescopeLE` (ADQ:2085) + `.toLE` (ADQ:2108) + **`.retarget`**
+  (ADQ:2122) + `.nil` / `.cons` / `.outHasType` / `.lowerHead` / `.withWitness`
+  / `.withWitnessAndChain` (ADQ:2136-2213) + `.toApplicationWith` (ADQ:2480) +
+  `.toApplicationWithSelfAdequacy` (ADQ:4896).
+- **Premise swap, three sites, one token each**: `FixedHeadResult` (ADQ:2590),
+  `FixedHeadResultAt` (ADQ:2639), `FixedHeadProducer` (ADQ:2931) now take
+  `LR.FixedHeadTelescopeLE`.  This is the interesting engineering datum: a
+  single-file `lake env lean` after the swap produced **exactly one error**, in
+  `of_orderedLink`.  The eight Group-B adapters, the four Group-C leaf sites
+  and both `CoherentFixedHeadStep` producers elaborated **unchanged** — dot
+  notation (`htel.toApplicationWithSelfAdequacy`) dispatched to the LE lemmas
+  by itself.  Naming the LE lemmas identically inside the `FixedHeadTelescopeLE`
+  namespace is what bought the zero-ripple landing.
+- `LR.FixedHeadTerminalLink.le_bot` / `.not_nonbot` (ADQ:2844/2855) — the
+  second refutation.
+- `LR.FixedHeadTelescopeLE.ofOrderedLink` (ADQ:2947) — **the repaired ordered
+  peel.**  It takes *no* terminal law: it returns the reached observation with
+  its witness, plus a *factory* `∀ outTy, out.HasType outTy → outTy ≤ reachedTy
+  → telescope`.  The base typing the old `term` supplied is just the caller's
+  own `hout`, and the comparison is handed to the caller — which is the only
+  place `hout`/`hA` exist, since they are inputs of `LR.constDefEq` fixed before
+  any pattern is matched.
+- `LR.FixedHeadTerminalDominance` (ADQ:3160) + `.of_exact` + `.nil` +
+  **`LR.FixedHeadProducer.of_dominance`** (ADQ:3206).
+- `LR.FixedHeadProducer.of_orderedLink` (ADQ:3114) is KEPT as the reference
+  statement with a `.toLE` inserted and a docstring that now says it is vacuous
+  twice over and must not be counted as progress.
+
+#### What `FixedHeadProducer` now rests on
+
+`hTyReg` (the registered type's own observation, an input — the peel transports
+an observation, it does not manufacture one) + `hout` (**already a hypothesis
+of every leaf**, `out.HasType outTy` in `LRS.IotaRHSDefEq`) +
+`LR.FixedHeadTerminalDominance`.  The ordered layer machinery — `link`,
+`consPeel`, `forallE_inst` lockstep, capture alignment — is fully proved and
+enters through `LR.FixedHeadTelescopeLE.ofOrderedLink`.  Net: the four leaf
+`producer` hypotheses are, for the first time, reducible to a statement that is
+not refutable, and the irreducible content is **one comparison**: the caller's
+result-type observation lies below the observation the ordered peel reaches.
+
+Where that comparison must eventually come from, recorded so it is not
+re-derived: it relates a logical-relation observation of the syntactic result
+type `A` (the caller's `outTy`, carried by `hA`) to a semantic-interpretation
+observation of the peeled registered type.  `LE_Interp.Witness` is downward
+closed under `≤` (`.mono`) and the observation sets are directed
+(`LE_Interp.…join'`), so the two have a common upper bound — but the peel's
+terminal is a function of the *initial* `headTy` and the layer `argCap`s, so
+using the join would mean choosing `hTyReg` at a large enough observation.
+That is a join/maximality theory for `Witness`, not a leaf-local fact, and it
+is the honest next design pass on this obligation.
+
+#### Remaining tower (updated)
+
+1. `LRS.CtorSpineTypeUniqPath` — unchanged; environment-level.
+2. `LR.CoherentIotaLeafStep Γ₀` — unchanged.
+3. δ-definition residual (`LR.ConstDefnDeepStepR` / `LR.ConstDefnDeepInstStep`)
+   — unchanged; the δ-rank component (probeK).  *Independently attackable.*
+4. `LR.CoherentFixedHeadStep Γ₀` — **DONE**, still conditional on
+   `LR.FixedHeadConvertStep Γ₀` alone; unaffected by this session's premise
+   swap (its proof did not change a character).
+5. `LR.FixedHeadConvertStep Γ₀` — residual `PiHeadNorm`.  **Blocked on the same
+   irreducible factor as `PiPathInv`.**
+6. `LR.FixedHeadTerminalDominance` (NEW, replaces the refuted
+   `FixedHeadTerminalRetarget` and `FixedHeadTerminalLink`) — the four leaf
+   `producer` hypotheses.  *Independently attackable*: it is adequacy-free and
+   `PiPathInv`-free, living entirely in the shape/witness layer.
+7. `∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth` — unchanged.  Blocked on
+   `PiPathInv`, or on the inner/outer depth mismatch.
+8. Assembly: `LR.CoherentRetainedNatStep.of_steps` needs only
+   `CoherentSelfStep.of_leafStepsDeep` plus item 4.
+
+**Build note for the fixture slice:** only `ShapeLogRel.lean` and
+`ShapeLogRelAdequacy.lean` changed, and only
+`Lean4Lean.Experimental.ShapeLogRel` then
+`Lean4Lean.Experimental.ShapeLogRelAdequacy` were built (both exit 0).  The
+`ShapeLogRel.lean` change is purely additive apart from two proofs whose
+*statements* are byte-identical (`TypedTelescope.fixedHeadShapeChain`,
+`HasTypeStratifiedS.spineWF_of_foldl`).  The `ShapeLogRelAdequacy.lean` change
+is additive apart from the three-site premise swap described above.  The D0/D1/D2
+fixture oleans (`SExprParamsD0/D1/D2`) remain stale by design from the previous
+four sessions and still need the central rebuild; no fixture source edit is
+expected from this session either.  **Note for that rebuild:** `ShapeLogRel.lean`
+changed this session for the first time in four sessions, so anything downstream
+of it — not only the Adequacy module — must be rebuilt.
+
+— session-C subagent 10
+
+### probeW lands: three §4.4 facts cost no rung, the fourth costs rung 0, and the `FixedHeadConvertStep` docstrings were wrong (2026-08-15, session-C subagent 11)
+
+`ShapeLogRel.lean`: **zero errors, zero sorries**, warning set **identical** to
+baseline (23 → 23, `diff` empty).  `ShapeLogRelAdequacy.lean`: **zero errors**,
+the same sole `sorry` at `LR.iotaWitnessStep` (ADQ:8631, token ADQ:8661 — it
+moved from 8348/8378 only because ~283 lines landed above it), warning set
+**identical** to baseline (100 → 100, `diff` empty; the eight new
+`unusedSectionVars` the additions would have raised are suppressed with
+`omit [Params.Semantic] in`, the linter's own prescribed fix, applied to the
+eight declarations that genuinely do not use the instance).  `SExpr.lean`
+untouched, and **no change to it is needed** — every lemma the port wanted was
+already available there or in `ShapeLogRel.lean`.
+
+**No new `sorryAx`.**  All 48 landed results check with
+`[propext, Classical.choice, Quot.sound]`, several with only
+`[propext, Quot.sound]`.  Negative control run in the same file:
+`LR.iotaWitnessStep`, `LR.adequacy` and `LR.adequacyAt` all report
+`[propext, sorryAx, Classical.choice, Quot.sound]`, so the check discriminates
+and nothing landed here consumes unconditional adequacy.
+
+#### LEAD WITH THIS: the suspected 16C′ ⇄ 18A′ cycle does not exist
+
+`LRS.PiPathInv` — the single residual of the chain wall — now has a producer
+that takes **no adequacy input whatsoever**:
+
+```
+LRS.PiPathInv.of_crLadder_noAdequacy (SLR:15381)
+  (srp : LRS.ParRedSDefeq) (cr : LRS.CRComplete)
+  (std : LRS.PiStandard)   (inv : LRS.PiEdgeInv) : LRS.PiPathInv
+```
+
+Every hypothesis is an L4L-18A′ transport of a Church–Rosser /
+standardization / subject-reduction fact.  The two semantic side conditions
+probeCR had left open — `LRS.PiNotFunTyped` and `LRS.PiNotProof` — are
+discharged here **from soundness alone**, with no rung.  So 18A′ can be
+scheduled independently of the ADQ fixpoint, and item 1
+(`LRS.CtorSpineTypeUniqPath`, which goes through `.of_piPathInv`) inherits the
+same clean dependency.
+
+#### Why the four §4.4 facts split the way they do
+
+*Disjointness* is a statement about **head shapes**, and `LE_Interp` already
+records one: `WShape.sort r` and `WShape.forallE b f` are incomparable, and
+`LE_Interp.sound` transports a shape across a strong equality, so a sort
+equated to a Pi would carry both shapes at once.  No fixpoint rung is involved
+— hence `LRS.SortForallEDisj.of_soundness` (SLR:15113),
+`LRS.PiNotFunTyped.of_soundness` (SLR:15124),
+`LRS.PiNotProof.of_soundness` (SLR:15135) take no adequacy hypothesis.
+
+*Injectivity* is a statement about the **level**, and `WShape.sort` records
+only `decide (u ≠ .zero)`.  The sharp boundary is machine-checked as
+`LRS.sortInv_bit_only` (SLR:15469): soundness recovers that bit and **nothing
+more**.  This is also the strongest available non-vacuity evidence for the
+whole pass — if `[Params] [Params.Semantic]` were inconsistent, or if the
+soundness machinery proved too much, `LRS.SortInv` would fall out of the same
+two lines.  It does not.
+
+`LRS.SortInv` therefore needs a rung, and the rung is **0**:
+`HasTypeStratifiedS.sort'` is a *nullary* constructor whose depth index is a
+free variable (`HasTypeStratifiedS.sort_zero`, SLR:15160), so the observation's
+subject never consumes depth.  Neither probeS wall is reachable: bounded output
+does not apply (the conclusion is `False` or a bare level equation, so nothing
+is re-decorated), and the leaf supplies no anchor (the only certificate demanded
+is for a syntactic sort).
+
+#### The two wrong docstrings, corrected
+
+**`LR.FixedHeadConvertRightValid` (now ADQ:2515).**  The old text said the
+residual is `PiHeadNorm` = `TypeWHNFEx` + `PiHeadStable`.  That is wrong in
+**both** directions, and `LRS.TypeWHNFEx` never arises at all — the Prop
+carries `TyDefEq A A a` as a *hypothesis*, so the left endpoint's weak-head
+normal form is **given**, not manufactured.  What the observations really are:
+
+* `a = .sort r`: *exactly* a transport, namely `LRS.SortHeadNorm` (SLR:15405,
+  the SExpr transport of `VEnv.IsDefEq.reduce_sort`, HeadReduction:493, which
+  Theory proves).  Machine-checked **both ways**:
+  `LR.fixedHeadConvertRightValid_sort_of_transport` (ADQ:2555) and
+  `LRS.SortHeadNorm.of_fixedHeadConvertRightValid` (ADQ:2570).  Nothing weaker
+  suffices, nothing stronger is demanded.
+* `a = .forallE b f`: `LR.tyDefEq_forallE_unfold` (SLR:15425) is `.rfl`, and
+  the first two conjuncts of the unfolded `LRS.ValTyPi2` *are* the two
+  weak-head reductions — that half is `LRS.PiHeadNorm`, CR-covered.  The
+  remaining four (`TypeDefEqPath` ×2, `TyDefEq B₁ B₂ b`, `LRS.PiDefEq`) are
+  semantic **component** data the CR ladder does not produce, isolated as
+  `LR.PiComponentTransport` (SLR:15436); see
+  `LR.fixedHeadConvertRightValid_forallE_of_parts` (ADQ:2582).
+
+**`LR.FixedHeadConvertStep` (now ADQ:2470).**  Its conclusion is
+`TyDefEq A B a`, not `TyDefEq B B a`, so the sort case additionally demands
+that `A` and `B` reach the **same** sort.  Discharged from three inputs, none
+of them `TypeWHNFEx`: `LRS.SortHeadNorm`, `LRS.SubjectRedS` (a CR-ladder item)
+and `LRS.SortInv` (the rung-0 item) — `LR.fixedHeadConvertStep_sort_of_parts`
+(ADQ:2602).
+
+**`LR.FixedHeadConvertStep.of_rightValid` (now ADQ:2536).**  The old "one line
+away" framing understates the price.  The *line* is one line; the *input* is
+the full uncollapsed `JointStratifiedInversion`: unbounded-depth `sortInv`, and
+an `IsDefEq`-valued — i.e. already collapsed — `forallEInv` with endpoint
+stratification bookkeeping at `n - 1`, strictly stronger than the path-valued
+`LRS.PiPathInv` the rest of the development charges.  Corrected in place.
+
+#### G4: the rung-0 consumption is real, and is mitigated, not papered over
+
+`LR.FixedHeadConvertStep` is depth-free, so it has to hold at rung `0` — and
+there its sort observation would consume a `LRS.SortInv` produced *at rung 0*
+by `LRS.SortInv.of_adequacyAtDepth_zero`.  That is same-rung consumption at
+exactly that rung.  The probe's `of_parts` route is sufficient but not
+necessary, so the mitigation taken is the one `LR.SelfAdequateDefeqStepAt`
+(ADQ:6974, with `.of_lowerAdequacy` at ADQ:7006) already uses:
+
+```
+LR.FixedHeadConvertStepAt Γ₀ outerDepth (ADQ:2635)
+  -- adds: depth < outerDepth → HasTypeStratifiedS Γ₀ A (.sort u) core depth →
+```
+
+* `LR.FixedHeadConvertStep.at` (ADQ:2647) — the indexed form is a **weakening**
+  of the depth-free one, so demanding it never demands more.
+* `LR.FixedHeadConvertStepAt.zero` (ADQ:2655) — **the mitigation.**  At rung 0
+  the indexed step is unconditional, so the rung that *produces* `LRS.SortInv`
+  consumes nothing from itself.  The same-rung consumption exists only for the
+  depth-free Prop.
+* `LR.fixedHeadConvertStepAt_sort_of_lowerAdequacy` (ADQ:2664) — at every
+  positive rung the sort observation takes its `LRS.SortInv` from the strictly
+  lower family.  The index has exactly one job and the arithmetic is explicit:
+  `depth < outerDepth` forces `0 < outerDepth`, which is what puts rung `0`
+  inside `lower`.
+
+**Landed BESIDE the depth-free Prop, not replacing it, and here is the
+migration.**  `convert` is spent inside
+`LR.FixedHeadShapeChain.pathSemantics` (SLR:14506) while zipping a
+`SExpr.PathSpineWF`, whose `conv`/`ret` edges carry a bare `IsDefEq` and no
+shape, witness or endpoint validity — so there is no certificate at the
+consumption site to index on.  Supplying one there is the G5 gap, a different
+obligation; migrating `LR.CoherentFixedHeadStep.of_convertStep` (ADQ:6140) and
+`LR.FixedHeadTelescope(LE).toApplicationWith` (ADQ:2756, 2801) to the indexed
+form is blocked behind it and is not a one-step change.  Nothing was weakened
+to hide the consumption.
+
+#### Vacuity discipline
+
+Standing policy after the two false Props earlier today.  Every new `Prop` this
+session is checked:
+
+* The three proved disjointness facts are *refutations*, so the risk is that
+  the judgment they refute is empty.  It is not: `LRS.nonvacuous_sort`
+  (SLR:15457) and `LRS.nonvacuous_pi` (SLR:15483) inhabit `IsDefEq` at both
+  shapes involved.
+* `LRS.sortInv_bit_only` (SLR:15469) is the **negative control** described
+  above — the sharp boundary showing the machinery does not prove too much.
+* `LRS.SortHeadNorm` — inhabited on the diagonal
+  (`LRS.sortHeadNorm_diagonal`, SLR:15488); it is the transport of a theorem
+  Theory proves.  No derivation of `False` found.
+* `LR.PiComponentTransport` — inhabited on the diagonal
+  (`LR.piComponentTransport_diagonal_witness`, SLR:15491).  No `False` found.
+* `LR.FixedHeadConvertStepAt` — vacuous at rung 0 by construction, so the check
+  is done at a *positive* rung: `LR.fixedHeadConvertStepAt_nonvacuous`
+  (ADQ:2697) exhibits a syntactic sort meeting all four hypotheses at
+  `outerDepth = 1` **and** the conclusion simultaneously.  Not empty-hypothesis
+  vacuous, not refutable at the one instance computable outright, and implied
+  by the depth-free Prop.  No `False` found.
+* `LRS.SortForallEDisjAt` / `LRS.SortInvAt` are faithful at `d = 0`
+  (`LRS.SortForallEDisj.of_at_zero` SLR:15179, `LRS.SortInv.of_at_zero`
+  SLR:15184), because the certificate they demand holds unconditionally.
+  `LRS.PiNotFunTyped` and `LRS.PiNotProof` are deliberately **not** indexed:
+  their subject is an arbitrary Pi, so recovering a bare form from a depth-`d`
+  form would need `LRS.PathRestratifyAt`-strength uniform depth bound (probeS
+  Part 7), which collapses the depth hierarchy.  Preserved from the probe.
+
+#### Placement rule used
+
+Dependencies decided the file, with one deliberate exception.  Everything whose
+*statement* mentions only `LE_Interp` / `LR` / `LogRel` / `SExpr` went to
+`ShapeLogRel.lean` (the shape layer, the three disjointness facts, the whole CR
+ladder, `LRS.SortHeadNorm`, the `tyDefEq_*` unfoldings,
+`LR.PiComponentTransport`, the vacuity witnesses).  Everything whose statement
+mentions an ADQ Prop (`LR.ContextualAdequacyAtDepth`,
+`LR.FixedHeadConvertRightValid`, `LR.FixedHeadConvertStep`) went to
+`ShapeLogRelAdequacy.lean`.  **The exception:** the four per-observation
+`fixedHeadConvert*` theorems have SLR-only dependencies but were placed in ADQ
+anyway, immediately beside the docstrings they correct — a corrected docstring
+whose evidence sits 6 000 lines away in another file is a docstring that will
+go wrong again.
+
+#### Remaining tower (updated — items 1, 5 and 7 restated)
+
+1. `LRS.CtorSpineTypeUniqPath` — unchanged as an obligation, but its route
+   through `LRS.PiPathInv` is now **adequacy-free**: `.of_piPathInv` composed
+   with `LRS.PiPathInv.of_crLadder_noAdequacy` reduces it to L4L-18A′ alone.
+2. `LR.CoherentIotaLeafStep Γ₀` — unchanged.
+3. δ-definition residual (`LR.ConstDefnDeepStepR` / `LR.ConstDefnDeepInstStep`)
+   — unchanged; the δ-rank component (probeK).  *Independently attackable.*
+4. `LR.CoherentFixedHeadStep Γ₀` — **DONE**, still conditional on
+   `LR.FixedHeadConvertStep Γ₀` alone; its proof did not change a character.
+5. `LR.FixedHeadConvertStep Γ₀` — **re-diagnosed.**  It is *not* "residual
+   `PiHeadNorm`".  At the sort observation it is
+   `LRS.SortHeadNorm` + `LRS.SubjectRedS` + `LRS.SortInv`, all three of which
+   are now producible (the first two from 18A′, the third at rung 0).  At the
+   Pi observation it is `LRS.PiHeadNorm` (18A′-covered) **plus**
+   `LR.PiComponentTransport`, which the CR ladder does **not** cover — that is
+   the honest residual.  Shapes other than `sort` and `forallE` are outside
+   this analysis.  Carries the G4 tripwire; indexed variant landed beside it.
+6. `LR.FixedHeadTerminalDominance` — unchanged.  *Independently attackable*:
+   adequacy-free and `PiPathInv`-free.
+7. `∀ depth, LR.SelfAdequateDefeqStepAt Γ₀ depth` — unchanged as an obligation,
+   but its "blocked on `PiPathInv`" premise is now milder: `PiPathInv` no
+   longer waits on the ADQ fixpoint, only on 18A′.
+8. Assembly: `LR.CoherentRetainedNatStep.of_steps` needs only
+   `CoherentSelfStep.of_leafStepsDeep` plus item 4.
+
+#### The exact remaining inputs to the 16C′ leaf
+
+* **From L4L-18A′ (Theory transports, no adequacy):** `LRS.ParRedSDefeq`,
+  `LRS.CRComplete`, `LRS.PiStandard`, `LRS.PiEdgeInv`.  These four give
+  `LRS.PiPathInv`, hence `LRS.PiHeadNorm` and `LRS.SubjectRedS` as well.
+  `LRS.SortHeadNorm` is a fifth, of the same kind
+  (`VEnv.IsDefEq.reduce_sort`, HeadReduction:493).
+* **From the ADQ fixpoint, at rung 0 only:** `LRS.SortInv`, via
+  `LR.ContextualAdequacyAtDepth 0`.
+* **Not covered by either:** `LR.PiComponentTransport Γ₀` — the component half
+  of the Pi observation of `LR.FixedHeadConvert{Step,RightValid}`.  This is the
+  one genuinely new named residual this session produced.
+
+**Build note for the fixture slice:** only `ShapeLogRel.lean` and
+`ShapeLogRelAdequacy.lean` changed, and only
+`Lean4Lean.Experimental.ShapeLogRel` then
+`Lean4Lean.Experimental.ShapeLogRelAdequacy` were built (both exit 0).  The
+`ShapeLogRel.lean` change is **purely additive** — one appended block, every
+pre-existing byte unchanged.  The `ShapeLogRelAdequacy.lean` change is additive
+apart from three docstrings rewritten in place (no statement, proof or name
+touched).  The D0/D1/D2 fixture oleans (`SExprParamsD0/D1/D2`) remain stale by
+design and still need the central rebuild; no fixture source edit is expected
+from this session.  `ShapeLogRel.lean` changed again, so everything downstream
+of it must be rebuilt.
+
+— session-C subagent 11
+
+### R11 ports, `PiComponentTransport` dissolves into a shape-level induction, and the "last input" docstring is retracted (2026-08-15, session-C subagent 12)
+
+Three landings, one retraction, one probe-only finding.  The headline is the
+second item: the residual the previous session recorded as *"the one genuinely
+new named residual"* is not a residual at all.
+
+#### 1. Rung R11 ported (`ShapeLogRel.lean`)
+
+`plans/probes/probeR11-piedgeinv.lean` ported verbatim, plus its supporting
+lemmas: `LRS.PiTypeInv` (:15267, the one new `Prop`) and
+`LRS.PiTypeInv.of_strong` (:15466, proved outright from `IsDefEq.strong` +
+`IsDefEqStrong.forallE_inv'` — no CR, no adequacy), `LRS.parRedS_forallE_path`
+(:15493), `LRS.normalEqPiInv` (:15529), `LRS.PiEdgeInv.of_crLadder` (:15572),
+`LRS.PiEdgeInv.of_crLadder_noAdequacy` (:15594), the composites
+`LRS.PiPathInv.of_crLadder_R11` (:15609) and
+`LRS.crComplete_is_the_last_input` (:15660), and non-vacuity witnesses
+`LRS.piTypeInv_nonvacuous` / `LRS.piEdgeInv_nonvacuous` (:16018/:16027).
+
+Two facts worth keeping, both about R11's price:
+
+* **R11 sits strictly BELOW the `PiHeadNorm` rung, not beside it.**  Not one
+  step performs a weak-head reduction: no `LRS.PiStandard`, no
+  `LRS.PiHeadNorm`, no `LRS.ReduceForallE`, no `LRS.TypeWHNFEx`.  The `≫*`
+  chains from `LRS.CRComplete` are consumed *as chains*.
+* **R11 costs `LRS.PiNotProof` but not `LRS.PiNotFunTyped`** — one of the two
+  sort facts, not both.  Knowing *both* `NormalEq` endpoints are Pis makes
+  `etaL`/`etaR` structural (a `.lam` is not a `.forallE`), so they die by
+  `cases`.  `LRS.NormalEqPiInvL`, which knows only the right endpoint's shape,
+  must refute `etaL` semantically and therefore does need the second fact.
+  Six of eight `NormalEq` constructors are structural in `normalEqPiInv`.
+
+Why the conclusion stays path-valued, recorded in the `parRedS_forallE_path`
+docstring: `ParRed.forallE_inv` cannot be iterated along a chain because the
+codomain components live in the *shifting* contexts `A₀::Γ`, `A₁::Γ`, … and
+SExpr's `ParRed` has no context-conversion lemma (it is ported only at `rfl`
+and `weak'`).  The fix is to convert each step to a typed equality immediately
+via `LRS.ParRedSDefeq` and walk the codomain one edge at a time with
+`TypeDefEqPath.defeqDF_l`.  Collapsing the accumulated path would charge
+`TypeDefEqPath.collapse`, i.e. raw type uniqueness.
+
+#### 2. RETRACTION — `LRS.CRComplete` is **not** the last input; the CR ladder is circular
+
+Received mid-session from the coordinator (probe
+`plans/probes/probeR12-parredS-clean.lean`, green, no `sorryAx`), and it
+invalidates the gloss the previous session landed on
+`LRS.crComplete_is_the_last_input`.  `VEnv.ParRedS.defeq` / `.standard` do NOT
+depend on `weakN_iff`; their `sorry` roots are `IsDefEqU.sort_inv` and
+`IsDefEqU.forallE_inv_stratified` — the 16C′ deliverables themselves:
+
+    LRS.PiPathInv = SExpr.forallE_inv ⇒ forallE_inv_stratified
+      ⇒ IsDefEqU.forallE_inv ⇒ ParRed.defeq ⇒ ParRedS.defeq
+      ⇒ LRS.ParRedSDefeq ⇒ (R11) LRS.PiPathInv
+
+The β case is where the dependency is essential, for a reason worth stating
+rather than citing: firing β requires reconciling an application's domain with
+its abstraction's own domain, which *is* Pi injectivity.  The two essential
+uses are `ParRed.defeq` (ChurchRosser, β case) and `StRed.triangle`
+(HeadReduction, β case) — anchor on the **names**, both files are moving.
+
+Docstrings corrected in place (no statement, proof or name touched):
+
+* `LRS.crComplete_is_the_last_input` (:15660) — full circularity note; the
+  theorem is retained verbatim because it is a *true implication*, and keeping
+  the mis-named target visible is how the ledger records that the arrow does
+  not point where it was thought to.
+* `LRS.PiPathInv.of_crLadder_noAdequacy` (:15403) — the claim "the
+  suspected 16C′ ⇄ 18A′ cycle does not exist" is narrowed to what is actually
+  proved: no cycle with the **ADQ fixpoint**.
+* the R11 subsection header, `LRS.PiEdgeInv.of_crLadder`,
+  `LRS.PiPathInv.of_crLadder_R11`, `LRS.CtorSpineTypeUniqPath.of_crLadder`,
+  and ADQ's `LR.MajorChainAnchorStep.of_crLadder` /
+  `LR.FixedHeadConvertStep.of_crLadder`.
+
+**R11 is an interderivability result, not a reduction.**
+`LRS.PiEdgeInv.of_piPathInv` runs the other way in one line.  What R11 buys is
+real but narrower than advertised: single-edge Pi injectivity suffices, so the
+path-valued form is not independently needed.
+
+Not ported for budget: the coordinator's sort-typed narrowing
+(`LRS.ParRedSDefeqSort` / `CRCompleteSort` / `PiStandardSort` and
+`LRS.PiPathInv.of_crLadder_R12`).  It is the natural next port and is
+orthogonal to everything below.
+
+#### 3. HEADLINE — `LR.PiComponentTransport` is the inductive step of an induction on the SHAPE LEVEL
+
+Probe `plans/probes/probeR13-…` aside, the work is
+`plans/probes/probeR12-picomponent.lean`, landed at `ShapeLogRel.lean`
+:15733-:15963.  The previous session's account —
+"`LRS.ValTyPi2`'s first two conjuncts are `LRS.PiHeadNorm`; the remaining four
+are semantic component data the CR ladder does not produce" — reads one
+unfolding correctly and the obligation wrongly.
+
+**The component data at the Pi observation is the same statement one shape
+level down.**  Unfolding `TyDefEq A B (.forallE b f)` at level `n+1` exposes
+`TyDefEq B₁ B₂ b` and, inside `LRS.PiDefEq`,
+`TyDefEq (F.inst a) (F.inst b') (f.app p)` — all at level `n`.  So the convert
+step at `n+1` consumes the convert step at `n`, and `PiComponentTransport` is
+not new data: it is the inductive step.
+
+Also: **the two-reduct form is illusory.**  Both weak-head reductions in
+`LR.PiComponentTransport` reduce the *same* `B`, so `WHRedS.determ` collapses
+them (`LR.PiComponentTransport.of_diag` :15785, converse `.diag` :15791).
+There was never anything to reconcile.
+
+Landed: `LR.PiComponentTransportDiag` (:15776), `LR.ConvertStepAt` (:15797),
+`LR.ConvertStepAt.path` (:15806) and `.path_right` (:15818),
+`LRS.IndTyHeadNorm` (:15835), `LR.convertStep_forallE` (:15851),
+`LR.convertStep_sort` (:15899), `LR.convertStepAt_all` (:15920),
+`LR.PiComponentTransport.of_crLadder` (:15944).  In ADQ:
+`LR.FixedHeadConvertStep.of_crLadder` (:2672),
+`LR.FixedHeadConvertRightValid.of_crLadder` (:2679),
+`LR.FixedHeadConvertStep.of_crLadder_R11` (:2691).
+
+Cost per shape constructor of `WShape (n+1)`, which is the whole content:
+
+| shape          | obligation |
+| -------------- | ---------- |
+| `bot`          | `True` |
+| `lam`, `ctor`  | `True` |
+| `sort r`       | `LRS.SortHeadNorm` + `LRS.SubjectRedS` + `LRS.SortInv` (level-uniform; a `LogRel` *field*, no recursion) |
+| `forallE b f`  | `LRS.PiHeadNorm` + `LRS.SubjectRedS` + `LRS.PiEdgeInv` + the step at level `n` |
+| `indTy`        | `LRS.IndTyHeadNorm` — **the one new obligation** |
+
+Three of six are `True`.  Two implementation notes worth keeping:
+
+* The Pi rung concludes the **heterogeneous** `TyDefEq A B`, not the
+  right-endpoint form.  That is strictly more convenient: `LRS.PiEdgeInv`
+  hands back paths `A₁ ⇝ B₁` and `G₁ ⇝ F₁` that slot directly into
+  `LRS.ValTyPi2`'s two `TypeDefEqPath` fields, so no path is reversed,
+  composed, or collapsed.
+* `LR.ConvertStepAt.path` is what lets a *single-edge* convert step consume
+  `LRS.PiEdgeInv`'s *path*-valued output — induction on the path, `trans_ty` at
+  each join.  Path collapse is never charged anywhere in the layer.
+* `LRS.PiInstDefEq`'s raw fields (`leftDefEq`/`rightDefEq`) come from
+  `IsDefEqStrong.subst` at the equality substitution `a ≡ b' : A₁`
+  (`Ctx.SubstEq.cons`), charging no semantics at all.
+
+**`LRS.IndTyHeadNorm` has no upstream analogue.**  Theory's `reduce_*` family
+stops at `IsDefEq.reduce_sort` (HeadReduction:493) and `.reduce_forallE`
+(:512); there is no `reduce_const`.  It is CR-ladder *shaped* (a head-form
+transport, no semantic component data), not adequacy-shaped, and it is the only
+such residual the induction exposes.
+
+**G4 is unaffected.**  The induction is on the *shape level*, orthogonal to the
+adequacy rung.  `LRS.SortInv` is consumed exactly where it was — at the sort
+observation, at every level — so `LR.FixedHeadConvertStepAt` remains the right
+mitigation and nothing about the rung-0 same-rung consumption changes.
+
+Read honestly against the retraction in §2: this does **not** make the convert
+step free, because `LRS.PiEdgeInv`/`LRS.PiHeadNorm` are inside the loop.  What
+it does say is sharper and still worth the session: **`LR.FixedHeadConvertStep`
+demands nothing beyond the 16C′ leaf itself**, plus `LRS.SortInv` at rung 0 and
+`LRS.IndTyHeadNorm`.  It was recorded as a separate obligation; it is not one.
+
+#### 4. `LRS.CtorSpineTypeUniqPath` closes end-to-end
+
+`LRS.CtorSpineTypeUniqPath.of_crLadder` (SLR :15676) and
+`LR.MajorChainAnchorStep.of_crLadder` (ADQ :1180).  `of_piPathInv` already
+existed; R11 supplies its input.  Same honest reading as §3: the residual costs
+exactly `LRS.PiPathInv` and adds nothing on top of it — in particular no
+adequacy rung and no raw type uniqueness.
+
+#### 5. Probe-only — the `CoherentIotaLeafStep` frame layer is mechanical once the type shape rides along
+
+`plans/probes/probeR13-rectframe.lean` (green, no `sorryAx`; **not landed**).
+The previous session established that the frame layer is *not* mechanical
+because `LogRel.DefEqRect` is indexed by an element shape **and** a type shape
+`(m, a)` while `LRS.CtorFrame` is indexed by the element shape alone.  The
+probe localizes that failure exactly: **it is entirely in the frame's index,
+not in the transport.**
+
+`LRS.RectFrame` is `LRS.CtorFrame` with the type shape threaded alongside the
+element shape and `HasType` coherence recorded wherever the element shape
+moves — same four constructors, same level arithmetic.  With it,
+`LRS.RectFrame.rect` is four one-liners: `LogRel.DefEqRect.mono_l` for `mono`,
+`LogRel.LiftEquiv.rect` in each direction for `lift`/`unlift`.  The frame also
+composes (`LRS.RectFrame.trans`).
+
+The blocking case is `mono` and the reason is precise: `DefEqRect.mono_l` needs
+`m.HasType a` **and** `m'.HasType a` for one common `a`, and a frame recording
+only `m ≤ m'` can supply neither.  Choosing `a` inside the transport is exactly
+the independent re-selection of the type observation that the N2 decision
+exists to prevent.  So the honest statement of the residual is not "prove a
+transport lemma" but **"produce `RectFrame`, not `CtorFrame`"** — the shape must
+be threaded positionally from the leaf that owns it, in the frame's
+*producers*.  `LRS.CtorFrame.TyWitness` names that demand and
+`LRS.CtorFrame.rect_of_tyWitness` shows there is nothing left to prove once it
+is met.  Left as a probe because upgrading the index touches the frame
+producers, which is not an additive change.
+
+#### Vacuity discipline
+
+Six new `Prop`s this session, all checked.  `LRS.PiTypeInv` and
+`LRS.RectFrame` are **proved/inhabited outright**, so they cannot be false.
+The other four carry explicit non-degenerate witnesses:
+
+* `LRS.piTypeInv_nonvacuous` / `LRS.piEdgeInv_nonvacuous` — the hypothesis is
+  satisfiable with *no* environment assumptions, in the empty context: a Pi
+  over two sorts (`LRS.nonvacuous_pi .sort .sort`).
+* `LR.piComponentTransportDiag_nonvacuous` (:16054) — sharper than the
+  pre-existing diagonal witness: the *reduct* is chosen by the caller and
+  determinism forces agreement.  So the diagonal form can only fail off the
+  diagonal, which is precisely where the level induction supplies it.
+* `LR.convertStepAt_nonvacuous` (:16070) — at the **sort** observation, a
+  non-degenerate shape at every level and every relevance bit, with a
+  content-carrying conclusion (it forces `B` to reach the *same* sort).
+* `LRS.indTyHead_nonvacuous` (:16080) — honestly environment-*conditional*:
+  inhabited as soon as any nullary inductive type is declared.  There is no
+  `Params`-free inductive type, and recording that is the correct statement of
+  the residual's scope.
+
+No new `Prop` was left unwitnessed and no derivation of `False` succeeded.
+
+#### Build note
+
+Only `ShapeLogRel.lean` and `ShapeLogRelAdequacy.lean` changed, plus two new
+probes (`probeR12-picomponent.lean`, `probeR13-rectframe.lean`).  Both targets
+built in order, both exit 0.  `ShapeLogRel.lean`: **zero warning delta**,
+verified by sorted diff against a pre-change baseline; **zero sorries**.
+`ShapeLogRelAdequacy.lean`: **exactly one** sorry, `LR.iotaWitnessStep`
+(declaration :8716, token :8746); no warning falls in any inserted range and no
+warning names any inserted declaration.  Both files' changes are additive apart
+from the docstring corrections listed in §2, none of which touched a statement,
+proof, or name.  Everything downstream of `ShapeLogRel.lean` needs rebuilding.
+
+— session-C subagent 12
+
+### The CR ladder banks as a *consumer* of the leaf; `TypeDefEqPath` moves to `SExpr.lean` (2026-08-15, session-C subagent 13)
+
+Source: `plans/probes/probeR13-loop.lean` (740 lines, green, all 22
+`#print axioms` `sorryAx`-free).  R13 proved the ladder rung
+`LRS.ParRedSDefeq` and the L4L-16C′ leaf `LRS.PiPathInv` **interderivable**.
+That closes the ladder as a way to *discharge* the leaf — any proof of the
+rung is a proof of the leaf — but the very same fact makes the ladder a
+valuable downstream **consumer**.  This session banks the consumer direction.
+
+#### 1. The `TypeDefEqPath` relocation (the one non-additive change)
+
+`TypeDefEqPath` and its whole conversion API — `single`, `trans`, `leftType`,
+`rightType`, `left`, `right`, `symm`, `defeqDF`, `defeqDF_l`,
+`defeqDF_l_path`, `subst` — moved out of `ShapeLogRel.lean` (old :10244–:10317)
+and into `Lean4Lean/Experimental/SExpr.lean:3613`, immediately after
+`IsDefEq.defeqDF_l` (:3588) and `HasType.defeq_l` (:3592).
+
+* **It is clean.**  The API's only inputs are `IsDefEq.defeqDF`,
+  `IsDefEq.defeqDF_l` (:3588), `IsDefEq.subst` (:3255) and `Ctx.Subst` (:3025)
+  — every one SExpr-level.  Nothing about it was logical-relation-flavoured.
+* **Zero consumer fixups.**  `ShapeLogRel.lean` re-elaborated with every
+  existing consumer *unchanged*, and `ShapeLogRelAdequacy.lean` likewise: the
+  name `Lean4Lean.SExpr.TypeDefEqPath` is unchanged, and both files see it
+  through the same namespace.  The signal the brief asked for — a consumer
+  breaking — did not appear.  75 lines left SLR, replaced by a 9-line pointer
+  note: net −66.
+* **`TypeDefEqPath.collapse` deliberately stayed** in `ShapeLogRel.lean`
+  (now :10521).  It did not sit in the moved block and it has one extra input,
+  `LogRel.RawTypeUniq` (:10514), which is declared there.  Moving it would
+  have dragged raw type uniqueness into `SExpr.lean` for no gain.
+* **Placement deviation, recorded.**  The brief asked for the inversion suite
+  "beside `IsDefEqStrong.forallE_inv'` (:2284)".  That is not reachable:
+  `IsDefEq.hasType` is at :2370 and `Ctx.Subst` at :3025, both *after* :2284,
+  so no formulation of the path API can precede `forallE_inv'`.  The suite
+  therefore sits with the path API at :3705–:3844, with docstrings pointing
+  back to `forallE_inv'`, whose proof style it mirrors exactly.
+
+#### 2. S1 — the inversion suite (SExpr.lean)
+
+`IsDefEqStrong.app_inv'` (:3705), `.lam_inv'` (:3753), `.forallE_inv_path`
+(:3804).  Each also returns the `TypeDefEqPath` from the subject's **own**
+type to the declared type `V`; that is the whole novelty over Theory's
+`VEnv.HasType.app_inv` / `.lam_inv`, and it is what removes every
+`IsDefEq.trans_l` / `uniqU` fixup the Theory proofs spend.  Recorded in the
+docstrings.
+
+Each measures `[propext, Quot.sound]`, each is `#sorryRoots`-CLEAN, and the
+dependency walker confirms **none of them reaches `IsDefEq.strong`** — nor
+`LRS.PiPathInv`.  They are pure structural case analysis on `IsDefEqStrong`.
+
+#### 3. S2 — the loop as a downstream consumer (ShapeLogRel.lean, at EOF)
+
+`LRS.PatStep`, `.of_typeUniq`, `.of_piPathInv`, `applyS_congr`,
+`ParRed.defeq_of_piPathInv`, `ParRedS.defeq_of_piPathInv`,
+`LRS.parRedSDefeq_of_piPathInv`, `LRS.piPathInv_iff_parRedSDefeq` (headline),
+`LRS.PiEdgeInv.of_piPathInv`, `LRS.PiPathInv.of_piEdgeInv_collapse`,
+`LRS.patStep_nonvacuous`.
+
+**The payoff, docstringed prominently at the section head.**  The moment 16C′
+lands, the ladder is free: `LRS.ParRedSDefeq` outright, `LRS.SubjectRedS`
+(already landed as `WHRedS.defeq_of_piPathInv`), and the single-edge
+`LRS.PiEdgeInv`.  It also retires the `sorryAx` that Theory's
+`VEnv.ParRed.defeq` and `VEnv.StRed.triangle` carry — probeR12 measured their
+roots as `IsDefEqU.sort_inv` / `IsDefEqU.forallE_inv_stratified`, i.e. the
+16C′ deliverables themselves.  The walker confirms the route reaches
+`LRS.PiPathInv` and **not** `LRS.CRComplete`, `LRS.PiStandard`,
+`LRS.SubjectRedS`, `LRS.PiEdgeInv`, `LogRel.RawTypeUniq` or `LR.adequacy`.
+
+**One correction to the brief's framing, machine-checked.**  `LRS.PatStep` was
+to be banked as "the second, independent uniqueness site", and in *content* it
+is: `.of_typeUniq` proves it from raw type uniqueness and from nothing about
+Pi shapes.  But it is **not an extra residual on top of the leaf**.  Every
+redex a `Pattern.Action` can match is a constant-headed spine, and spine type
+uniqueness is already reduced to the leaf in this file
+(`LRS.constSpineTypeUniqPath`, :11458), so `LRS.PatStep.of_piPathInv` — five
+lines, mirroring the `extra` case of the landed `WHRed.defeq_of_piPathInv`
+(:11507) — discharges it from `LRS.PiPathInv` as well.  Hence
+`LRS.parRedSDefeq_of_piPathInv`: the rung from the leaf with **no side
+conditions**.  This strengthens rather than weakens the banked claim, and both
+docstrings say so.  `LRS.PiEdgeInv.of_piPathInv` was landed for the same
+reason: two existing docstrings (:15361, :15579) already referred to it as
+"a one-liner in the other direction"; it is now checked rather than asserted.
+
+`LRS.PiPathInv.of_piEdgeInv_collapse` carries the trade explicitly: collapsing
+a path to a single edge costs `LogRel.ContextualRawTypeUniq`, so the
+`PiEdgeInv` framing **trades the 16C′ leaf for the L4L-17 co-deliverable**
+rather than avoiding it.
+
+#### 4. S3 — the closure records
+
+`beta_congr_no_piInv` (the β *congruence* needs no Π-inversion at all),
+`LRS.BetaFire` + `.of_piPathInv` (the *contraction* is where the leaf is
+charged), `betaSort_domain_unconstrained` (sort-typedness constrains the
+result type, never the domain — the sort restriction is not an escape), and
+`LRS.ChainAnchorAt` + `.uniformDepthBound` / `.of_uniformDepthBound` (the
+stratification escape's consumer-side obstruction, *provably equivalent* to a
+uniform stratification bound — the same fatal proposition probeS identified).
+Banked so nobody re-attempts the dead routes.
+
+#### 5. Vacuity discipline
+
+Three new `Prop`s (`LRS.PatStep`, `LRS.BetaFire`, `LRS.ChainAnchorAt`), all
+witnessed:
+
+* `LRS.patStep_nonvacuous` — environment-conditional, like
+  `LRS.indTyHead_nonvacuous`: inhabited wherever `Pattern.Action` is, and at
+  the action's own type the conclusion *is* `action.sound`, so no derivation
+  of `False` is available that does not refute `Pattern.Action.sound`.  Two
+  independent derivations (`.of_typeUniq`, `.of_piPathInv`) rule out
+  underivability.
+* `LRS.betaFire_nonvacuous` — at a **non-degenerate** instance: the witness of
+  `betaSort_domain_unconstrained`, whose application domain is syntactically
+  different from the abstraction's own.  Empty context, no environment
+  assumptions.
+* `LRS.chainAnchorAt_nonvacuous` — hypothesis inhabited in the empty context
+  with no environment assumptions, which is what makes the
+  `.uniformDepthBound` equivalence a real obstruction rather than a vacuous
+  one.
+
+No new `Prop` was left unwitnessed and no derivation of `False` succeeded.
+
+#### 6. Build note
+
+Three targets, built in the prescribed order, all exit 0:
+`Lean4Lean.Experimental.SExpr`, then `...ShapeLogRel` (31s), then
+`...ShapeLogRelAdequacy` (12s).  Every block compiled **first try**.
+
+*Warning-profile delta: zero.*  SExpr 6, ShapeLogRel 23, Adequacy 100 — the
+same counts as the pre-change baseline, and verified by diff to be the same
+warnings (SLR modulo the line shift from the relocation; ADQ byte-identical).
+No `omit [Params.Semantic] in` was needed: every new declaration genuinely
+uses its section variables.
+
+*Sorry inventory, exact:*
+
+* `SExpr.lean` — **4**, the known off-path ones, unchanged in identity and
+  shifted +254 lines by the insertion: :4051, :4287, :4390, :4456 (was :3797,
+  :4033, :4136, :4202).
+* `ShapeLogRel.lean` — **0**.
+* `ShapeLogRelAdequacy.lean` — **exactly 1**, `LR.iotaWitnessStep`
+  (declaration :8716, token :8746), untouched.
+
+Everything downstream of `SExpr.lean` needs rebuilding; `SExprParams*` was
+deliberately not built here.
+
+— session-C subagent 13
diff --git a/plans/l4l-16d0-slice-map.md b/plans/l4l-16d0-slice-map.md
new file mode 100644
index 00000000..3865476e
--- /dev/null
+++ b/plans/l4l-16d0-slice-map.md
@@ -0,0 +1,445 @@
+# L4L-16D0 slice map — concrete execution plan
+
+## Worker update (2026-08-14)
+
+The two interface blockers found by this review are now closed in the active
+working tree:
+
+- **G1:** `IsDefEqStrong.defn` is a finite, definition-specific constructor.
+  It combines registered constant metadata, independently strong-typed RHS
+  evidence, and the local proof-carrying `Pattern.Action`; it does not add an
+  environment oracle or a recursive premise to ordinary `const`.  The new
+  case is threaded through weakening/substitution/stratification and semantic
+  soundness, and the Experimental SExpr, logical-relation, and adequacy
+  modules build.
+- **G2:** weak constant-endpoint inversion is implemented by
+  `HeadConstLevelsWF`, `IsDefEq.headConstLevelsWF`, and the left/right
+  `const_*_levelsLength` corollaries.  The proof covers beta exposure and raw
+  registered equations through `Params.henv.defEqWF`; no new semantic field
+  is required.
+
+Consequently D0b is no longer blocked on the definition knot, and the
+concrete `iotaSite.levelsLength` field has a generic source.  The remaining
+D0 work begins at the concrete Nat `Params`/`Params.Semantic` construction
+and the union/non-overlap/site derivations listed below.
+
+## Implementation update (2026-08-14)
+
+**D0a and D0b are complete in the active working tree.**
+`Lean4Lean/Experimental/SExprParamsD0.lean` now preserves the Nat-only D0a
+certificate and layers D0b over it with the checked declaration
+`d0def : Nat := Nat.zero`.  The extended `d0Env`/`D0Pat` inventory, all six
+`Params.Semantic` fields, the definition-specific strong contraction, both
+generated Nat iota sites, and the endpoint `d0SortInvS` are kernel-checked.
+In particular, the iota-site proof is replayed against `d0Env` itself, so it
+remains valid for contexts that mention `d0def`; it is not obtained by
+casting such contexts back into the smaller Nat environment.
+
+`nix develop --command lake build Lean4Lean.Experimental.SExprParamsD0`
+is green (122 jobs), the D0 file has no `sorry`/`admit`, and an exact
+`#guard_msgs`/`#print axioms` pin records the endpoint closure.  The pin
+contains the inherited 16C′ `sorryAx`, the fixture's persistent-map
+contracts, and named concrete `native_decide` observations; closing 16C′ is
+expected to remove the inherited `sorryAx` without changing the D0 instance.
+The gap/status tables below remain as the pre-implementation audit record.
+
+Audience: the L4L-16D worker session and John. Produced read-only on
+2026-08-14 by an analysis session; no `.lean` file was touched.
+
+## Snapshot
+
+All file:line references below were read against this state and **will
+drift**: the 16C′ session is actively editing `Experimental/` (one write
+observed hours before this read). Re-verify line numbers before acting.
+
+| File | Size | mtime at read |
+|---|---|---|
+| `Lean4Lean/Experimental/SExpr.lean` | 182,986 B | 2026-08-13 13:07 |
+| `Lean4Lean/Experimental/ShapeLogRel.lean` | 583,544 B | 2026-08-14 01:21 |
+| `Lean4Lean/Experimental/ShapeLogRelAdequacy.lean` | 181,248 B | 2026-08-14 03:31 |
+
+- git HEAD `931c686` (detached), working copy dirty in exactly the three
+  files above plus plans docs. jj: `.jj/` present, `jj workspace list` =
+  `default: muqzvzmw 6c45e8a9` only.
+- Open admissions on the D0-relevant path at read time:
+  `SExpr.lean:3516` (`WHRed.weakU_inv`, `extra` case), `SExpr.lean:3739`
+  (`WHRedS.defeq`), `SExpr.lean:3842`/`3908` (`InferType(S).hasType`),
+  and the sole adequacy admission `ShapeLogRelAdequacy.lean:3058` inside
+  `LR.adequacy` (declared at `ShapeLogRelAdequacy.lean:2856`).
+  `ShapeLogRel.lean` is sorry-free. D0's endpoint inherits these until
+  16C′ closes them; that is expected and does not block D0.
+
+## Params/Semantic field inventory
+
+### `class Params` — `SExpr.lean:24-45` (11 fields)
+
+| Field | Signature (exact) | Line |
+|---|---|---|
+| `env` | `VEnv` | 25 |
+| `henv` | `env.Ordered` | 26 |
+| `univs` | `Nat` | 27 |
+| `Pat` | `(p : Pattern) → p.RHS × p.Check → Prop` | 28 |
+| `classify` | `Name → Option Classification` | 29 |
+| `pat_simple` | `Pat p r → ∃ sp : SimplePattern, p = sp.toPattern` | 30 |
+| `pat_wf` | `Pat p r → p.WF classify` | 31 |
+| `pat_uniq` | `Pat p₁ r → Pat p₂ r' → Subpattern p₃ p₁ → p₂.inter p₃ = some p₄ → p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r'` | 32-33 |
+| `pat_app_l` | `Pat p r → Subpattern (.app p₁ p₂) p → ¬Subpattern (.app p₃ p₄) p₁` | 36 |
+| `pat_app_l_uniq` | `Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p → Subpattern (.app p₁' p₂') p' → Subpattern (.var p₃) p₁ → p₁'.inter p₃ = none` | 37-38 |
+| `pat_app_uniq` | `Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p → Subpattern (.app p₁' p₂') p' → Subpattern p₃ p₁ → Subpattern p₃' p₂' → p₃.inter p₃' = none` | 39-40 |
+
+`pat_app_r_arity` (41-42) and `extra_pat` (43-45) are **commented out** —
+no coverage law is currently demanded of the instance.
+`Classification` (`ctor`/`etaCtor`/`symb`/`indTy`) is at 8-16;
+`Pattern.WF classify` at 18-22 (note: `.app` adds 1 to the extra-arity
+accumulator and each `.var` adds 1, so a recursor head's `symb` arity is
+major-arity + 1, counting the major itself).
+
+### `class Params.Semantic [Params]` — `SExpr.lean:1844-1924` (6 fields)
+
+| Field | Shape | Line |
+|---|---|---|
+| `structureEta` | `env.structEtas rule → strong self-typing of rebuild → strong self-typing of major → IsDefEqStrong … rebuild ≡ major` | 1845-1856 |
+| `ctor` | `env.constants c = some ci → ls.length = ci.uvars → ∀ cl : CtorBundle.IsCtor c, {F : CtorBundle c cl // IsDefEqStrong Γ (mkInst ls ci.type) (F.rhs ls) (.sort F.u)}` — **data** (Subtype), quantified over all `ls`, `Γ` | 1857-1862 |
+| `defn` | `Pat (.const c) r → ∃ value closed, r = (.fixed value closed, .true) ∧ ∀ ci ls Γ, … → IsDefEqStrong Γ (.const c ls) (mkInst ls value) (mkInst ls ci.type)` — **unconditional** equations (no typing inputs) | 1867-1875 |
+| `iotaRule` | `Pat (RecursorIotaPattern rec major ctor arity) r → Pattern.IotaRule r` | 1879-1884 |
+| `iotaSite` | rule + `captureType` + `CaptureTyping` + `IotaTyping` + `MatchesS` + weak redex self-`IsDefEq` + `∃ u, IsDefEq Γ A A (.sort u)` → `Pattern.IotaReductionSite …` | 1891-1914 |
+| `registered` | `env.defeqs df → ls.length = df.uvars → strong lhs self-typing → strong rhs self-typing → IsDefEqStrong Γ (mkInst ls df.lhs) (mkInst ls df.rhs) (mkInst ls df.type)` — receives endpoint typings as **inputs** | 1919-1924 |
+
+Recent-additions audit requested by the plan:
+
+- `iotaRule`, `iotaSite`, `registered` — landed as fields (above).
+- `closedHasTypeStrong` — **not a field**: a derived theorem at
+  `SExpr.lean:2074-2101`; the comment at 2073 says explicitly "derived
+  from `Params.henv`, not added to `Params.Semantic` as an oracle".
+  Likewise `registeredRhsStrong` (2105) and `IotaRule.rhsStrong` (2116).
+- lemma (C) / coherence field (registered-equation lhs heads classify as
+  symbols) — **not landed**. Sole mention is
+  `plans/l4l-16-completion-plan.md:485`: "(e) lemma (C) and the coherence
+  field only if the first-order composition still needs raw telescope
+  alignment (it may not …)" — conditional, deferred. No such field exists
+  in either class.
+
+Key supporting definitions (same file): weak `IsDefEq` 1260-1280 with
+**raw** `extra` (1279-1280: `env.defeqs df → ls.length = df.uvars → …`);
+`SpineWF` 1286-1299; `Pattern.CaptureTyping` 1585-1588;
+`Pattern.IotaTyping` 1593-1607; `Pattern.IotaRule` 1613-1623 (fields
+`pat`, `df`, `registered`, `rhsClosed`, `capturePaths`, `rhsTower`);
+`Pattern.IotaReductionSite` 1643-1667 (fields `typing`, `matched`,
+`levelsLength`, `captureSpine`, `lhsCollapse`, `dfs`, `defeqs`,
+`checked`); `Pattern.Action` 1676-1684; `IotaReductionSite.action`
+1930-1960 (derives the `Action` generically — the instance never builds
+one for iota directly); `CtorBundle.IsCtor` 1774, `CtorBundle` 1783-1790
+(note `hu0 : u ≠ .zero`), `CtorBundle.rhs` 1792.
+
+`IsDefEqStrong` 1798-1839. Two rules matter enormously for D0:
+
+- `const` (1803-1813) carries the premise
+  `∀ {r}, Pat (.const c) r → Γ ⊢ r.1.applyS ls Empty.elim ≡ .const c ls : mkInst ls ci.type`
+  (1811-1812) — the definition-unfolding equation is a **prerequisite**
+  of typing any constant that has a defn pattern (comment 1807-1810: the
+  direction serves `LE_Interp.Const.pat` semantic recursion).
+- `extra` (1836-1838) needs a full `Pattern.Action` (hence a `Pat`
+  member) **plus strong typings of both endpoints**.
+
+Consumption sites (fixing the contracts): `IsDefEqStrong.mkS`
+(1965-2068) uses `ctor` at 1992/1998, `defn` at 2006, `structureEta` at
+2060, `registered` at 2067. Endpoint:
+`VEnv.IsDefEqU.sort_invS` at `ShapeLogRelAdequacy.lean:3698-3708` —
+signature `[Params.Semantic] → OnCtx Γ (Params.env.IsType Params.univs)
+→ IsDefEqU … (.sort u) (.sort v) → u ≈ v`. Nothing beyond the two
+instances is required.
+
+## Certificate sources
+
+| Artifact | Location | Certifies | Feeds |
+|---|---|---|---|
+| `CertifiedExtension` | `Theory/Typing/InductivePatternEnv.lean:59-66` | one extension rule: `df`, `SimplePattern`, RHS/Check payload, `covers` at `stripLams (df.lhs.instL ls)` | `Pat` union half (D1/D2); `quot` instance at 113-146 (D1) |
+| `iotaExtension` | `InductivePatternEnv.lean:157-184` | every generated rule fits the beta-collapsed extension shape | D2 |
+| `assembleEnv` / `_defeqs` / `_defeq_cases` / `_WF` | `InductivePatternEnv.lean:189/247/289/305` | assembled env, exact defeq inversion, Ordered | alternative `env`/`henv` route (D2) |
+| `AssembledPat` | `InductivePatternEnv.lean:330-336` | union pattern set; **only** `pat_simple` (339) and `ext_covers` (349) proved | `Pat` at D2; the four non-overlap laws are missing at this level (gap G3) |
+| `BlockGenerationChecked` (+ `.WF`) | `Theory/Inductive.lean:2141` / `2812`; `identityBlockGeneration?` 2161 | checked block generation | rule data via accessors below |
+| `IotaPat` + block-local laws | `Theory/Typing/InductivePattern.lean:607-612`; `pat_simple` 617, `recover` 624, `pat_uniq` 640, `pat_app_l` 668, `pat_app_l_uniq` 679, `pat_app_uniq` 707 | the four non-overlap laws, block-locally | proof **templates** for D0's bespoke laws |
+| `RuleClosure` / `captureArgs` / `ruleRHS` / `ruleCheck` | `InductivePattern.lean:531/541/553/563` | closedness; RHS template `= RHS.appN (.fixed rule.rhs closed) captureArgs` — exactly `IotaRule.rhsTower`'s shape (`SExpr.lean:1622-1623`) | `Pat` payloads, `iotaRule` |
+| `pat_wf` (typed match soundness) | `Theory/Typing/InductivePatternWF.lean:543` (axioms pinned 943-949) | successful match ⇒ typed defeq | not directly a field; background for D2 |
+| L4L-10B match-inversion library | `Theory/Typing/Pattern.lean`: `RecursorIotaPattern` 304, `subpattern_inv` 346, `inter_some` 407, `inter_varN_const_some` 419, `inj` 439, `app_subpattern` 449; `Pattern.inter` 54-60; `SimplePattern` 242-248 (has `.defn`) | pattern combinatorics | the four non-overlap laws |
+| SExpr match layer | `SExpr.lean:802-807` (`MatchesS`), 848 (`MatchesS.varN_const_inv`) | SExpr-side spine decomposition | `iotaSite` |
+| Declaration history | `Theory/VDecl.lean:11-12` (`VDefVal.toDefEq`: lhs `= .const name (VLevel.params uvars)`); `Theory/Typing/Env.lean:19-55` (`VDecl.WF`, `.def` at 24-27), 57-67 (`WF'`/`WF`); `Theory/Typing/EnvLemmas.lean:112` (`WF → Ordered`) | how a definition's defeq is registered; Ordered | `env`/`henv` for D0b; `defn` |
+| Theory strong system | `Theory/Typing/Strong.lean:18` (`IsDefEqStrong`), 91-99 (`extra`: raw + typings, **no** action), 116-123 (`const`: **no** unfolding premise), 786 (`IsDefEq.strong`) | Theory-side strengthening | contrast for gap G1 — Theory has no knot, SExpr does |
+| Eta registry (L4L-15B) | `Theory/VEnv.lean:173/193-194` (`structEtas`, `addStructEta`); `VEnv.hasStructureEta_of_registry` pinned at `Tests/StructureEtaCapability.lean:82,100-103` | registered structure eta | `structureEta` at D4 only; vacuous in D0 |
+| Nat fixtures | `Lean4Lean/Theory/InductiveFixtures.lean:34` (`natDecl`), 51-52 (`natBlockGenerationChecked`), 88-93 (both rules, literal `vdefeq`), 72 (`kTarget = false`); `Lean4Lean/Verify/Environment/InductiveFixtures.lean:143` (`natDecl_wf`), 348-350 (`nat_final_matches_addInduct`, by `rfl`), 354-362 (`natFinalEnv_ordered`, axioms `[propext, Classical.choice, Quot.sound]`, `#guard_msgs`-pinned), **364 (`nat_env_wf : natFinalEnv.WF`)** — namespace `Lean4Lean.InductiveReplayFixtures` | the D0 environment, Ordered and WF, exists today | `env`, `henv` |
+| Other blocks | punit `Theory/InductiveFixtures.lean:136-201` (1 rule, `punitDecl_wf` 174, `punitEnv_ordered` 199); patBlock/patVec `Theory/Typing/InductivePatternFixtures.lean:25/53` (+ closures 102/105, assemble guards 168-169, **no Ordered**); tree/indexedTree `Theory/MutualInductiveFixtures.lean:51-58/122-129`; Bool `Theory/InductiveFixtures.lean:110-126` | candidate ladder | D2 fixtures; see disqualification below |
+
+## D0 fixture candidate
+
+**Chosen: the Nat block (`natFinalEnv`) + one new definition
+`d0def : Nat := Nat.zero`, staged as D0a (iota-only) then D0b (add the
+definition).**
+
+- Iota rules (from `Theory/InductiveFixtures.lean:88-93`):
+  `motive z s => Nat.rec motive z s .zero ≡ z` and
+  `motive z s n => Nat.rec motive z s (.succ n) ≡ s n (Nat.rec motive z s n)`.
+  Patterns: `.iota Nat.rec 3 Nat.zero 0` and `.iota Nat.rec 3 Nat.succ 1`
+  (major arity 3 = 1 motive + 2 minors; `nparams = 0`). Rule uvars = 1
+  (the motive's `Sort u`). `ruleCheck` degenerates to `.true` for Nat
+  (no params, no indices — `InductivePattern.lean:563` folds over empty
+  lists), so every `Action.dfs = []`.
+- classify table (5 literal names): `Nat ↦ .indTy 0`,
+  `Nat.zero ↦ .ctor 0`, `Nat.succ ↦ .ctor 1`, `Nat.rec ↦ .symb 4`
+  (extra-accumulation: the app contributes 1, three `varN` vars 3),
+  `d0def ↦ .symb 0` (D0b).
+- Environment: D0a = `natFinalEnv` as-is (`henv` = `natFinalEnv_ordered`).
+  D0b = `natFinalEnv.addConst d0def … |>.addDefEq (toDefEq …)` with
+  `VDecl.WF.def` (`Theory/Typing/Env.lean:24-27`) consed onto
+  `nat_env_wf`'s history (Verify `InductiveFixtures.lean:364`), Ordered
+  via `EnvLemmas.lean:112`.
+
+**Deviation from the plan's "one iota rule": Nat has two.** No
+Ordered-certified single-rule Type-valued block exists, and the only
+single-rule block with an Ordered proof is disqualified:
+
+- **punit is disqualified by `CtorBundle.hu0`.** `punitDecl` has
+  `uvars = 1`, `resultLevel = .param 0`
+  (`Theory/InductiveFixtures.lean:142,153`). `pat_wf` of its iota pattern
+  forces `classify PUnit.unit = some (.ctor 0)` (`Pattern.WF`,
+  `SExpr.lean:18-22`), so `CtorBundle.IsCtor PUnit.unit` holds and
+  `Semantic.ctor` (1857-1862) must produce a bundle at **every** `ls`,
+  including `ls = [SLevel.zero]` — where `mkInst ls ci.type =
+  .const PUnit [zero]` types only in `.sort zero`, forcing `F.u = zero`
+  against `hu0 : u ≠ .zero` (`SExpr.lean:1790`). This matches the
+  completion plan's first-order/non-Prop staging
+  (`l4l-16-completion-plan.md:465-480`; "Acc is the known exception").
+  *(Uncertainty flag: verified by signature analysis only, not by an
+  attempted build.)*
+
+Ranking: 1. **Nat** (Ordered+WF exist, literal kernel names, checks
+`.true`, always `u = 1 ≠ 0`); 2. patBlock (universes always `succ` but 3
+rules, mutual, no Ordered proof); 3. patVec (external `Nat` constants;
+no Ordered); 4. Bool (like Nat but no prebuilt block descriptor or WF);
+punit disqualified. Recommendation: do the zero rule first, succ second
+(the succ rule adds a recursive minor application on the RHS — the honest
+smoke test).
+
+## Sourcing table
+
+Status legend: READY (source exists, plumbing only), WORK (concrete
+construction, known shape), GAP (missing lemma/decision).
+
+| Field | Status | Source / adaptation |
+|---|---|---|
+| `Params.env` | READY | `natFinalEnv` (Verify `InductiveFixtures.lean:348-350`); D0b appends one const+defeq |
+| `Params.henv` | READY | `natFinalEnv_ordered` (354-356); D0b: `VDecl.WF.def` + `nat_env_wf` (364) + `EnvLemmas.lean:112`; needs the `addConst` freshness computation (G5b) |
+| `Params.univs` | READY | leave parametric: build the instance as a `def` over any `univs : Nat` |
+| `Params.Pat` | READY | bespoke inductive, 2 members (D0a) / 3 (D0b); payloads = `ruleRHS`/`ruleCheck` (`InductivePattern.lean:553/563`) over `natBlockGenerationChecked` (`InductiveFixtures.lean:51-52`) + a new `natRuleClosure` by `decide` (template `patTreeClosure`, `InductivePatternFixtures.lean:102-103`) (G5d) |
+| `Params.classify` | READY | 5-name literal table above |
+| `pat_simple` | READY | per-member `⟨.iota …, rfl⟩` / `⟨.defn _, rfl⟩` (`Pattern.lean:242-248`) |
+| `pat_wf` | READY | `decide`/`simp [Pattern.WF]` against the literal table |
+| `pat_uniq` | WORK | clone `IotaPat.pat_uniq` (`InductivePattern.lean:640-666`) for the 2-3 member set; zero-vs-succ cross cases via `RecursorIotaPattern.inter_some` (`Pattern.lean:407`) + ctor-name disequality; defn cases trivial (`.const` vs `.app` inter = `none`, `Pattern.lean:54-60`; only subpattern of `.const` is itself) |
+| `pat_app_l` / `pat_app_l_uniq` / `pat_app_uniq` | WORK | clone `InductivePattern.lean:668/679/707` with `app_subpattern` (`Pattern.lean:449`) + `inter_varN_const_some` (419); defn cases vacuous |
+| `Semantic.structureEta` | READY | vacuous: `d0Env.structEtas = fun _ => False` (empty at `Theory/VEnv.lean:178`; only `addStructEta` 193-194 extends it) — needs the small emptiness lemma (G5a) |
+| `Semantic.ctor` | WORK | two concrete bundles: zero `⟨Nat, [], [], 1, …⟩` with rhs `.const Nat []`; succ `⟨Nat, [.const Nat []], [], imax 1 1, …⟩` with rhs `= mkInst [] ci.type` syntactically; `hu0` via `SLevel.succ_ne_zero` (**lives at `ShapeLogRel.lean:20`, not `SExpr.lean`** — import or reprove, G5c); strong self-typings direct (`const`'s `F`/hpat premises vacuous for `Nat`: `IsCtor Nat` false, no `Pat` at `.const Nat`) |
+| `Semantic.defn` | D0a: READY (vacuous — no `Pat (.const c)` member). D0b: **GAP G1** | see Gaps |
+| `Semantic.iotaRule` | WORK | two descriptors: `df` = the registered rules (membership `.inl rfl`-style, cf. `InductiveFixtures.lean:104-106`), `rhsClosed` by `decide`, `capturePaths` from `captureArgs`'s paths (`InductivePattern.lean:541-549`: `.inl` of first 3 rec paths ++ `.inr` of ctor field paths), `rhsTower` = a `List.map` equation against `ruleRHS` (553-558) — mechanical |
+| `Semantic.iotaSite` | WORK + **GAP G2** | `typing`/`matched` from inputs; `dfs = []`, `defeqs` by `rfl` (checks `.true`); `levelsLength` **not derivable from the stated inputs** (G2); `captureSpine` (`PathSpineWF` against `df.type`'s telescope) and `lhsCollapse` (weak beta collapse of the applied tower, 3-4 `.beta` steps + congruence) built concretely per rule (G4) |
+| `Semantic.registered` (iota defeqs) | WORK (largest) | `lamDF` descent under the 3-4 binders to the bodies; at the body, `.extra` with the iota `Action` (weak `sound` = raw weak `extra` 1279-1280 + beta chain); strong redex typing built from scratch — dominated by one reusable derivation: strong self-typing of `mkInst ls (Nat.rec's type)` (a concrete Pi-tower derivation) |
+| `Semantic.registered` (defn defeq, D0b) | **GAP G1** | see Gaps |
+
+Endpoint: `sort_invS` (`ShapeLogRelAdequacy.lean:3698`) instantiates
+with nothing further; supply `OnCtx [] …` trivially and pin
+`#print axioms` (expect `sorryAx` from the five known admissions until
+16C′ lands).
+
+## Gaps
+
+- **G1 — the defn/strong-const circularity (interface-level; blocks the
+  definition half, D0b).** `Semantic.defn` (`SExpr.lean:1867-1875`) must
+  supply *unconditional* strong unfolding equations. The only
+  cross-constant rule in `IsDefEqStrong` is `.extra` (1836-1838), which
+  needs a `Pattern.Action` (hence a `Pat` member at `.const c`) **and** a
+  strong typing of `.const c ls`; the only constant-introduction rule
+  `const` (1803-1813) demands the unfolding equation as its premise
+  (1811-1812) at the *same* `(ls, Γ)`. So any derivation of the equation
+  strictly contains a derivation of itself — no finite derivation
+  exists. Omitting the defn pattern from `Pat` instead makes
+  `registered` (1919-1924) unsatisfiable for the registered defn defeq
+  (no `Action` without a `Pat` member). Either way, an env containing a
+  definition defeq admits no instance under the current interface.
+  Theory's system has no knot: its `const` has no unfolding premise and
+  its `extra` is raw (`Strong.lean:116-123`, `91-99`). Candidate
+  repairs, **16C′-owner decision required** (one-writer rule,
+  `l4l-16-completion-plan.md:748-751`): (a) weaken the `const` premise's
+  equation to weak `IsDefEq` — then it comes free from raw weak `extra`,
+  if `LE_Interp.Const.pat` (comment 1807-1810) tolerates weak; (b) add a
+  dedicated defn-unfolding constructor to `IsDefEqStrong` that types
+  only the rhs value. *(Confidence: high on the signature analysis, but
+  it is untested — task 2 below is a ≤30-line probe before escalating.)*
+- **G2 — `iotaSite.levelsLength` unsourceable.**
+  `IotaReductionSite.levelsLength : recLs.length = rule.df.uvars`
+  (`SExpr.lean:1657`) is not derivable from `iotaSite`'s inputs
+  (1891-1914). Fix: a new weak inversion lemma
+  `IsDefEq Γ (.const c ls) e T → env.constants c = some ci → ls.length = ci.uvars`
+  — provable by structural induction on the weak judgment (every rule
+  preserving a const endpoint carries the length or an IH); no such
+  lemma exists (grep negative). Small, generic, no interface change.
+- **G3 — union-level non-overlap still missing (D2, confirmed).**
+  `AssembledPat` carries only `pat_simple`
+  (`InductivePatternEnv.lean:339`) and `ext_covers` (349); the four
+  laws exist only block-locally (`InductivePattern.lean:640-740`), and
+  no cross-term (block-rule vs extension-rule) lemma exists anywhere.
+  Unchanged since the plan was written. D0 dodges it via the bespoke
+  `Pat`; D2 must pay it.
+- **G4 — no SExpr-side generic site builders.** `captureSpine`
+  (`PathSpineWF`) and `lhsCollapse` (beta collapse) have no generic
+  constructors; D0 builds them concretely per rule. Genericizing is
+  D1/D2 work, not D0.
+- **G5 — small missing pieces:** (a) structEtas-emptiness lemma for the
+  concrete env; (b) `addConst` freshness discharge over the concrete
+  constants function (see the memory note on decidability-discharge
+  hazards); (c) `SLevel.succ_ne_zero` is in `ShapeLogRel.lean:20`, not
+  `SExpr.lean` (import path or 3-line reproof); (d) `natRuleClosure`
+  not yet defined (one `decide` following
+  `InductivePatternFixtures.lean:102-103`).
+
+## Ordered task list
+
+Each item is one committed checkpoint; the working tree builds at every
+pause. All new code goes in **one new file**
+(suggest `Lean4Lean/Experimental/SExprParamsD0.lean`), importing
+`Lean4Lean.Experimental.ShapeLogRelAdequacy` and
+`Lean4Lean.Verify.Environment.InductiveFixtures`. No existing `.lean`
+file is edited.
+
+1. Workspace + skeleton: second jj workspace, new file with imports,
+   cold build. (Flagged: first build compiles the 583KB/181KB modules —
+   budget hours, not minutes.)
+2. **[RISK — do early, non-blocking]** G1 probe (≤30 lines): attempt a
+   strong self-typing of a defn constant whose pattern is in `Pat`;
+   confirm or refute the circularity; send the finding plus repair
+   options (a)/(b) to the 16C′ session. Do **not** change the interface
+   unilaterally.
+3. D0a environment layer: `natRuleClosure` (`decide`), the defeq
+   inventory lemma (`d0Env.defeqs df ↔ df = zeroRule ∨ df = succRule`),
+   the structEtas-emptiness lemma (G5a).
+4. `classify` + the `D0Pat` inductive + `pat_simple` + `pat_wf`.
+5. The four non-overlap laws for `D0Pat` (clone
+   `InductivePattern.lean:640-740`); assemble the `Params` instance
+   (parametric over `univs`).
+6. `Semantic.ctor` bundles + vacuous `structureEta` + the two `iotaRule`
+   descriptors (the `rhsTower` map equation).
+7. **[RISK — largest]** Derivation layer: strong self-typing of
+   `Nat.rec`'s instantiated type (reusable core); the G2 inversion
+   lemma; `registered` for the zero rule (lamDF descent + `.extra`
+   action + weak beta collapse), then the succ rule as a separate
+   checkpoint; `iotaSite` for both (captureSpine, lhsCollapse).
+8. Endpoint: close `Params.Semantic`; instantiate `sort_invS`
+   (`ShapeLogRelAdequacy.lean:3698`) at the instance; `#print axioms`
+   pin recording exactly the inherited 16C′ admissions. **This is the
+   D0a exit.**
+9. **[BLOCKED on G1]** D0b: add `d0def` (WF extension + freshness),
+   extend `Pat`/`classify`, populate `defn` and `registered`-for-defn
+   under the repaired interface. This completes D0 as specified in
+   `l4l-16-completion-plan.md:668-671`.
+
+## Parallel-start recommendation
+
+**Yes — start D0a now in a second jj workspace; do not wait for 16C′.**
+
+- Build isolation verified: `/.lake` is the first line of `.gitignore`,
+  so a second workspace materializes its own untracked `.lake`; the
+  worker's builds and D0's builds cannot touch each other. (`result`,
+  `.direnv` likewise ignored.) jj repo confirmed (`.jj/` present; one
+  workspace `default` today).
+- File isolation: D0 adds one new file and edits nothing the worker
+  owns, so the eventual merge is import-level only. This respects the
+  one-writer-per-`Experimental/` rule because the writer set is disjoint
+  by file and by workspace.
+- Known frictions: (i) cold first build; (ii) `SExpr.lean` /
+  `ShapeLogRelAdequacy.lean` are moving targets (mtimes within hours of
+  this read) and the contact surface — `Params`, `Params.Semantic`,
+  `IsDefEqStrong` — is exactly what 16C′ may still reshape; expect one
+  rebase-adapt pass when 16C′ lands; (iii) the D0a endpoint will carry
+  `sorryAx` from the five known admissions until then — gate D0a on
+  "instance fields sorry-free + endpoint compiles + axiom set exactly
+  the known list", not on a clean closure.
+- Sequencing dependency: only task 9 (D0b) waits — on the G1 decision,
+  which task 2 requests early. Everything else is decision-free.
+- Housekeeping: `.gitignore` ignores `plans/*` except an allowlist; add
+  `!/plans/l4l-16d0-slice-map.md` if this document should be versioned,
+  otherwise it stays local to this workspace.
+
+## Verification note (sibling session, 2026-08-14 ~12:25 EDT)
+
+The current `SExprParamsD0.lean` (mtime 11:20) elaborates **clean**: exit
+0, zero errors, zero sorry-bearing declarations; both `natSortInvS` and
+`d0SortInvS` compile with their guard-pinned axiom sets. Residue is 40
+lint warnings (30 unused-simp-arg, 6 semireducible class defs, 2 naming,
+2 simpa→simp) — 16E polish.
+
+Process note to the D0 worker: your 11:14 verification command
+(`lake env lean … --json | rg -m 10 'error'`) deadlocked for ~67 min —
+`rg -m 10` exits after ten matches, closing the pipe, and `lean` then
+blocks forever on write. It was killed at ~12:21 by the sibling session
+to unblock your shell; the ten error lines it finally returned describe
+the STALE 11:14 snapshot, already fixed by your 11:20 save. Do not
+re-fix them. For future checks, redirect to a file instead of piping
+through `rg -m N`.
+
+## D1 executed (2026-08-15) — outcome and D2-builder template
+
+D1 landed as `Lean4Lean/Experimental/SExprParamsD1.lean` (187 decls, no
+local admission; endpoint `d1SortInvS` and the sorryAx-free
+`d1qEnv_wf` pin in-source). Mutual-definitions half complete end to
+end; the quot semantic instance is blocked on the `CtorBundle.hu0`
+interface decision recorded at `SExprParamsD1.lean:2703-2755` (see the
+completion plan's D1 bullet for the decision framing).
+
+Extension template proven by the build (clone for D2+): env layer →
+Pat layer (laws by delegation + fresh-name intersection lemmas) →
+structural `Params` → transport functor `d(n)→d(n+1)` (clone
+`d0StrongToD1`; the `const`/`defn` cases use a
+`d1Pat_at_old_const`-style inversion plus the `ihDef` hypothesis; a
+`funext fun path => nomatch path` aligns the const-pattern capture
+map) → context/spine/PathSpine clones → strong-const chain (transfer
+old; `defn` constructor for new) → `Defn`/`Registered` (old defeqs via
+the previous level's `Semantic.closedHasTypeStrong` + transfer; new
+direct) → `Ctor` via bundle transfer → `IotaRule`
+destructure/rebuild → iota-site replay clone (swap env-lookup lemmas;
+the `defeqs_iff` cascade grows one `natRule_rhs_ne_*` native pair per
+new defeq) → assembly, endpoint, pin.
+
+Gotchas that cost cycles: term-mode `.trans`/`.symm` on
+`IsDefEqStrong` needs `by letI : Params := ...`; `Lookup` inside SExpr
+namespaces shadows Theory's (use `_root_.Lean4Lean.Lookup`);
+`VEnv.HasType.const` in a bare `have` needs `(U := ...)`;
+`addConsts`/`addQuot` compute via simp with per-step
+`addConst ... = some ...` lemmas over `native_decide` freshness;
+existential witnesses by `exact ⟨_, ...⟩` not `refine ⟨_, ?_⟩`.
+
+## Theory-side pattern API after D2 (2026-08-15)
+
+D2's build fed three reusable pieces back into
+`Theory/Typing/InductivePatternEnv.lean` (all `#guard_msgs`-pinned at
+`[propext, Quot.sound]`; pins verified load-bearing by a negative
+control):
+
+- `SimplePattern.HeadSep.app_l_uniq` (:245) and `HeadSep.app_uniq`
+  (:266) — the cross-block `(rule, ext)` engine cases, previously
+  inlined. The two landed union laws now call them (proof bodies
+  −21/−24 lines, statements and axiom closures unchanged).
+- `AssembledPat.recover` (:592) — the inversion principle
+  (`cases` cannot destructure `AssembledPat` at a concrete iota
+  pattern: stuck `varN` tower). Generalizes the fixture-local version;
+  the rule branch uses `gen.ruleEntry i constructor` and the ext
+  branch additionally yields `r ≍ (ext.rhs, ext.check)`.
+- Scope doc block (:639-666) — one `AssembledPat` covers exactly ONE
+  block (`ext_sep`'s pairwise `HeadSep` is unsatisfiable for two rules
+  sharing a recursor), so an N-block `Params` takes the N-way sum plus
+  N(N-1) hand-written ordered cross-block pairs per obligation.
+
+Migration for D3 (mechanical): drop any local `simple_app_l_uniq` /
+`simple_app_uniq` and call `(…headSep…).app_l_uniq h h' h₃` /
+`.app_uniq h h' h₃ h₃'` (`.symm` variants unchanged); replace
+`assembledPat_cases H` with `AssembledPat.recover Gen H`, and widen
+the ext-branch rcases pattern by one component
+(`⟨ext, hmem, hpattern⟩` → `⟨ext, hmem, hpattern, -⟩`). The per-block
+constructor *inventory* lemma remains per-fixture work — it depends on
+the concrete constructor list and cannot come from Theory.
diff --git a/plans/l4l-16e-promotion-map.md b/plans/l4l-16e-promotion-map.md
new file mode 100644
index 00000000..d1a06660
--- /dev/null
+++ b/plans/l4l-16e-promotion-map.md
@@ -0,0 +1,249 @@
+# L4L-16E promotion map — executable checklist
+
+**Addendum (2026-08-15, later the same day, after checkpoints
+`7b8a1b5e`/`b6896de1`).** Line references below predate two deletions
+(SExpr.lean −48 lines, ShapeLogRelAdequacy.lean −171; the leaf sorry is
+now ~ADQ:8583) — re-locate by declaration name. Status deltas against
+this map: (i) `InferType.hasType`/`InferTypeS.hasType` are DELETED
+(zero consumers, verified), as are `InferTypeS.weakU_inv`,
+`LRS.iotaDefEq_of_exactAt`, `LR.iotaActions_of_exact`; SExpr.lean's
+sorry count is now 2. (ii) The "dead chain" claim for
+`WHRed(S).weakU_inv` was WRONG: `WHRedS.weakU_inv` is live via the
+proved `InferType.weakU_inv`'s app/forallE cases and
+`Experimental/LogRel.lean:210` (`LRIsType.weak'` stuck case) — the
+`.extra` sorry stays, correctly documented in-source. (iii)
+`WHRedS.defeq` live sites are now exactly 3, all adequacy-trunk
+(`constDefEq`, `SelfAdequateConstStep.of_steps`,
+`adequacy_of_iotaWitnessStep`) — the delete-and-migrate disposition
+(iv) is therefore moot until the leaf closes; the sites shed with it.
+(iv) The `CtorBundle.hu0` deletion (decision (iii) below) is REFUTED —
+see `plans/probes/probeA1-hu0.lean` and the completion plan's corrected
+record; the Prop wall needs a Matches/classification-level design.
+(v) The stratification lever for the leaf is machine-refuted:
+`plans/l4l-16-stratified-observation-design.md` +
+`plans/probes/probeT-stratpi.lean`.
+
+Produced 2026-08-15 by a read-only recon session over the working tree
+(all citations verified against the live sources; draft statements
+type-checked against the current oleans). Companion to the 16E section
+of `plans/l4l-16-completion-plan.md`. Durable probe copies of the draft
+statements: `plans/probes/CoDeliverableDrafts.lean`,
+`plans/probes/SExprCounterpartDrafts.lean`.
+
+Headline correction to the plans: **both joint co-deliverables already
+exist verbatim in the trusted tree with `sorry` bodies.** 16E does not
+draft them; it proves them (and re-pins their guards).
+
+## (a) Co-deliverable dossiers
+
+### A1. `IsDefEqU.weakN_iff` — forward direction. Verdict: REAL WORK, open design. Top 16E risk.
+
+- Statement exists at `Lean4Lean/Theory/Typing/UniqueTyping.lean:171-174`;
+  the backward direction is proved (`h.weakN henv W`); the sole
+  obligation is the forward implication (strengthening).
+- Promised at roadmap.md 16E co-deliverable list;
+  l4l-16-completion-plan.md ("no SExpr counterparts yet");
+  l4l-16-sort-inversion-decision.md; allowlist entry
+  `Lean4Lean/Audit/SorryFrontier.lean:173`.
+- What hangs on it (already written, proved modulo this one sorry): the
+  inversion suite UniqueTyping.lean:176-368 (`VExpr.WF.weakN_iff`,
+  `IsDefEq.skips`, `weakN_iff'`, `OnCtx.weakN_inv`,
+  `HasType/IsType.weakN_iff`, the `weak'_iff` family,
+  `SpineWF.weakN_inv/weak'_inv`); `VLocalDecl.weakN_iff`
+  (Theory/LocalContext.lean:98); ~20 sites in
+  Theory/Typing/ChurchRosser.lean (:609-1701); Verify
+  (Typing/ConditionallyTyped.lean:72,126; Typing/Lemmas.lean:377). CR's
+  `VEnv.Params.structEta_weakN_inv` field is documented as the
+  structure-family specialization, supplied from this co-deliverable at
+  L4L-18A.
+- Route analysis:
+  - Semantic route: adequacy endpoints return judgment-level facts only
+    at observation heads (sort/Pi/ctor); strengthening of an arbitrary
+    pair is not an observation extraction. Interpretation-level descent
+    exists (`LE_Interp.weak'_iff`/`weak_iff` ShapeLogRel.lean:5893/5929;
+    `LogRel.LiftEquiv` + `lift/unlift` :10745-10885) but no bridge back
+    to arbitrary judgments.
+  - Derivation-induction route: SExpr weak `IsDefEq` has primitive
+    homogeneous `trans` (SExpr.lean:1263) and `defeqDF` (:1273) — the
+    trans midpoint is an arbitrary non-lift term (the documented
+    "genuinely untyped midpoints" wall). Chain normalization
+    (`WHRedS.ctorSpine_determ`) covers classified constructor heads
+    only; generalizing is standardization ≈ L4L-18A. Note
+    `WHRed.weakU_inv`'s `.extra` case is itself sorried
+    (SExpr.lean:3810) and is a prerequisite of any derivation-induction
+    attempt.
+  - Theory-CR route: circular (ChurchRosser.lean consumes `weakN_iff`).
+- No proof sketch exists anywhere in plans/. Recommendation: schedule a
+  dedicated design pass (two-strikes rule) BEFORE the 16C′ leaf closes;
+  do not treat as post-leaf cleanup.
+- POSTSCRIPT (later 2026-08-15): the design pass ran —
+  `plans/l4l-16-weakn-design.md` supersedes this dossier's route
+  analysis. Verdict: research-grade, 3–6 focused weeks via the SST
+  route; W0 wall witness machine-checked; W0/W1 proved at
+  `[propext, Quot.sound]`; re-scope recommendation on file.
+  Corrections to this dossier: `Theory/Typing/HeadReduction.lean` was
+  missing from this map (sorry-free-but-tainted `WHRed(S).weakU_inv`,
+  standardization `StRed`/`ParRedS.standard`, `reduce_sort/forallE`,
+  syntax-directed `InferType` with strengthening); the sorried
+  `.extra` case is the SExpr mirror only — Theory's is
+  proved-but-tainted; the `HasType.skips` repair idea above is
+  circular (it is a corollary of the target, UniqueTyping.lean:180-187
+  / 225-228); the pre-171 suite additionally rides on Injectivity's
+  three sorried endpoints.
+
+### A2. `VEnv.WF.registeredStructureHeadInversion`. Verdict: real work, shallower than A1 — AFTER a statement repair.
+
+- Statement exists at `Lean4Lean/Theory/Projection.lean:3518-3520` over
+  the four-field record at :3465-3512 (`weak'_inv`, `unique`,
+  `constructor_name_inv`, `constructor_inv`). Design docstring
+  :3449-3464: proof uses `IsDefEqU.weakN_iff` + injectivity of
+  registered inductive heads. Allowlist entry SorryFrontier.lean:174.
+- Per-field:
+  - `weak'_inv`: mostly consumption once `weakN_iff` closes
+    (`IsDefEqU.weak'_iff` UniqueTyping.lean:231, `SpineWF.weak'_inv`
+    :327, `HasType.skips` :226). Residual real step: registered
+    inductive-head injectivity below a lift (reflected indTy-observation
+    inversion) — implied machinery, not separately listed anywhere.
+  - `unique`: consumption + plumbing given `uniq`/`uniqU` + head
+    injectivity + `projectionCodes` congruence. `TrProj` fields
+    :3183-3199.
+  - `constructor_name_inv` / `constructor_inv`: **FALSE AS STATED.**
+    `TrProj` constrains its major only via `majorType`
+    (Projection.lean:3193) and `VEnv.WF` admits any declaration history
+    (axioms, defs). Counterexamples: `axiom ax : S` with
+    `major := .const ax ls`, `constructorArgs := []`, reflexive defeq
+    forces `ax = view.constructorName`; a `def mkAlias := S.mk` applied
+    to a full spine refutes `constructor_inv` (:3212 demands
+    `constructor_name_eq`). The Verify consumer is safe only because
+    its head survived `whnf` AND a `ctorInfo` lookup
+    (Verify/TypeChecker/WHNF.lean:59-83) — facts the Theory statement
+    never receives. REPAIR FIRST: add a head-classification premise
+    ("runtime head is the constructor of some registered view") and
+    budget the consumer-side change that supplies it. Same failure
+    class as the 2026-08-13 S1/S7-S9 audit.
+- Consumers: `TrProj.weak'_inv`/`defeqDFC`/`uniq`
+  (Verify/Typing/Lemmas.lean:679-686, 987-995), `Inner.whnf` projection
+  path (Verify/TypeChecker/WHNF.lean:63, 81).
+
+## (b) Promotion move-map
+
+The plans never pin target paths; targets below are derived from the
+constraints (audit surface = prefixes `Lean4Lean.Theory`/`.Verify`,
+SorryFrontier.lean:129; Theory must not import Verify; promotion
+requires zero sorries + stable API).
+
+| Module (current, Experimental/) | Suggested target | Notes |
+|---|---|---|
+| `SExpr.lean` | `Theory/Typing/SExpr.lean` | 4 live sorries must close/delete first: :3810 `WHRed.weakU_inv` `.extra`; :4033 `WHRedS.defeq` (superseded by `WHRedS.defeq_of_stratified_inversion` — delete/restate, migrate its two root-anchor consumers); :4136 `InferType.hasType`; :4202 `InferTypeS.hasType` |
+| `ShapeLogRel.lean` | `Theory/Typing/ShapeLogRel.lean` | live-sorry-free today |
+| `ShapeLogRelAdequacy.lean` | `Theory/Typing/ShapeLogRelAdequacy.lean` | 1 sorry (the 16C′ leaf) |
+| `UniqueTyping.lean` | fold into the adequacy module, or rename (e.g. `SExprUniqueTyping.lean`) | FILENAME COLLISION with `Theory/Typing/UniqueTyping.lean`; holds one compat theorem `IsDefEqStrong.uniq_sort` |
+| `SExprParamsD0.lean` (and D1+) | `Verify/Environment/SExprParamsD0.lean` (or Tests) | imports Verify fixtures — cannot go to Theory/ (Theory-imports-Verify gate) |
+
+Stays parked in Experimental/: NormalEq, ParallelReduction (L4L-18A),
+Stratified, StratifiedUntyped, Stronger, CoinductiveLogRel,
+DomainTheory, LogRel, StepIndexed, MoreStepIndexed, Thierry, Thierry2.
+
+Consumers to touch (verified: NOTHING in Lean4Lean/, Main.lean, or
+Tests imports `Lean4Lean.Experimental` today):
+
+1. The moved files' own `import Lean4Lean.Experimental.*` lines.
+2. `plans/probes/*.lean` import headers — or retire the probes: 16E
+   replaces the probe practice with in-source `#guard_msgs` pins.
+3. `Lean4Lean/Audit/SorryFrontier.lean:1-75` import block — REGENERATE
+   per the in-file recipe (:97-101) so the new Theory/Verify modules
+   enter the audited surface (the audit only sees imported modules —
+   without this the moved modules silently leave the surface); update
+   the ":103-104 Experimental is intentionally not imported" comment.
+4. Optionally `Lean4Lean/Theory.lean` root import list.
+5. No lakefile edit needed (globs cover the targets; the Experimental
+   lib entry stays for the residue; CI's
+   `lake build Lean4Lean.Experimental` still works).
+
+Collision risks (checked): no hard full-name clashes. SExpr's
+`Lean4Lean.Params` (SExpr.lean:5,:24) vs ChurchRosser's
+`Lean4Lean.VEnv.Params` first co-import inside the regenerated
+SorryFrontier — co-importable but confusing; consider renaming SExpr's
+to `SExpr.Params` during API stabilization. `Pattern.WF` is a new def
+on Theory's `Pattern` (no existing `WF` — verified). `Classification`,
+`WShape`, `SLevel`, `TShape`, `Valuation`, `LogRel`, `LE_Interp` have
+no Theory/Verify counterparts. The only hard collision is the
+`UniqueTyping.lean` FILE name.
+
+## (c) Allowlist artifact + exact edits
+
+Artifact: `Lean4Lean/Audit/SorryFrontier.lean` — compiled `run_cmd`
+audit (:201-218) comparing `sorryAx`-referencing declarations in the
+`Lean4Lean.Theory`/`Verify` surface against `allowlist : Array
+Lean.Name` (:134-188), currently exactly 22 entries (10 Tier V + 6
+Tier R + 6 Tier F). Enforced by `lake build
+Lean4Lean.Audit.SorryFrontier` (roadmap §6 gate; CI).
+
+- 22 → 21 (execution step 6, promotion): delete line 170,
+  `` `Lean4Lean.VEnv.IsDefEqU.sort_inv, `` — forced and safe once the
+  real proof lands (the audit fails in both directions).
+- Full 16E exit (execution step 7, co-deliverables): additionally
+  delete lines 171-174 (`forallE_inv_stratified`, `sort_forallE_inv`,
+  `weakN_iff`, `registeredStructureHeadInversion`) → **17 entries**
+  (Tier R residue: `NormalEq.parRed` only). The roadmap's "22 → 21"
+  describes step 6 only. Update the Tier R comment block (:169) and the
+  roadmap frontier row alongside.
+
+## (d) Gates
+
+"§6" lives in roadmap.md §6 "Gates and process" (:863-932), not the
+completion plan. Verbatim command block:
+
+```
+lake build Lean4Lean.Theory Lean4Lean.Verify
+lake build Lean4Lean.Audit.SorryFrontier
+lake build
+nix build --accept-flake-config .#lean4lean .#lake-dependency
+nix flake check --accept-flake-config --print-build-logs
+nix fmt --accept-flake-config -- --check flake.nix
+git diff --check
+```
+
+| Gate | Today | 16E action |
+|---|---|---|
+| Theory+Verify build | expected green (working-tree delta is Experimental/+plans/ only) | every `#guard_msgs` sorryAx pin that flips FAILS this build until re-pinned. Expected re-pin set: Theory/LocalContext.lean:137-141; Theory/Projection.lean:3522-3526; Verify/Typing/Lemmas.lean:1703-1741 (4 pins: `TrProj.weak'_inv`/`defeqDFC`/`uniq`/`structuralLaws`); Verify/TypeChecker/InferType.lean:1057-1060 (`inferProj.WF`); InductivePatternWF.lean:942-947 (`pat_wf`, sheds at the uniq/uniqU re-run) |
+| Sorry frontier | green at 22 | re-run after each allowlist edit (21, then 17) and after the import-block regeneration |
+| Default `lake build` | expected green | promoted modules join automatically |
+| Nix builds / flake check / fmt | last verified at the L4L-15R checkpoint | rerun at the promotion checkpoint (flake gate builds for real) |
+| `git diff --check` | measured green today (exit 0) | keep green |
+
+Roadmap §6 "Additionally" items binding 16E: new theorem roots need
+checked `#print axioms` output — none exist today because Experimental
+is ungated; candidates = `sort_invS`, `LR.adequacy`, `LE_Interp.sound`,
+`IsDefEqStrong.mkS`, `SExpr.forallE_inv`, `sort_forallE_inv`, the
+D-ladder endpoints (the AxiomProbe list is the ready-made inventory).
+`rg '^import Lean4Lean.Verify' Lean4Lean/Theory` must stay empty.
+Theory API changes additive-only. Non-command gate due at this
+boundary: the digama reconcile-or-defer decision — prepared analysis
+with defer recommendation already in
+`plans/l4l-16-boundary-digama-drift.md` (sign-off, not new work).
+
+## (e) Items the plans missed (now assigned in the completion plan)
+
+1. `constructor_name_inv`/`constructor_inv` statement repair (see A2)
+   — repair BEFORE proof work, plus consumer-side premise supply.
+2. `weakN_iff` forward has no recorded proof design — schedule the
+   design pass early; `WHRed.weakU_inv` `.extra` (SExpr.lean:3810) is a
+   prerequisite of any derivation-induction attempt and is currently an
+   off-path deferral.
+3. Promotion is blocked on the 4 off-path SExpr.lean sorries (:3810,
+   :4033, :4136, :4202) — they do NOT close with the 16C′ leaf; they
+   need their own pre-promotion step.
+4. SorryFrontier import-block regeneration at promotion (else silent
+   audit-surface loss).
+5. `UniqueTyping.lean` filename collision; `Lean4Lean.Params` vs
+   `VEnv.Params` near-collision first co-imports in the regenerated
+   frontier.
+6. The instance-generalization step is implicit: `sort_invS` holds at
+   `[Params.Semantic]`, public `sort_inv` quantifies over arbitrary
+   `VEnv.WF env`. "Closes from the instances" requires the generic
+   `Params`/`Params.Semantic` construction from any WF history —
+   nowhere staged; decide at D4 exit whether it is D4's endpoint or a
+   named 16E step.
+7. Doc rot: "22→21" vs 17-at-full-exit (see (c)); completion-plan
+   execution item 6 should point at the prepared digama note.
diff --git a/plans/l4l-18a-prime-scope.md b/plans/l4l-18a-prime-scope.md
new file mode 100644
index 00000000..01db55b3
--- /dev/null
+++ b/plans/l4l-18a-prime-scope.md
@@ -0,0 +1,532 @@
+# L4L-18A′ scope — Church–Rosser, standardization, and the normalization question
+
+Date: 2026-08-15
+
+Commissioned by the 2026-08-15 16C′ verdict, `plans/roadmap.md:735-741`:
+
+> The irreducible factor is `PiHeadNorm` = `TypeWHNFEx` (a well-typed type
+> HAS a weak-head normal form) + `PiHeadStable`. That is an existence claim,
+> so **L4L-18A′ is now a hard dependency of 16C′ and must be scoped to
+> include normalization, not merely Church–Rosser** — CR alone buys only
+> `PiEdgeInv`, one of the two factors already recoverable. Scoping pass:
+> `plans/l4l-18a-prime-scope.md`.
+
+Status: analysis complete; recommendation in §9. Companion probe
+`plans/probes/probeCR-scope.lean` — green, **16 banked results, all at
+`[propext, Quot.sound]`**, no `sorryAx`, no `Classical.choice`. The probe
+imports `Lean4Lean.Experimental.ShapeLogRel` only, so its independence from
+adequacy is structural rather than audited. No `Experimental/` or `Theory/`
+file was edited by this pass.
+
+---
+
+## 0. TL;DR
+
+1. **Strike normalization from L4L-18A′.** `TypeWHNFEx` is not needed. The
+   recorded decomposition `PiHeadNorm = TypeWHNFEx ∧ PiHeadStable`
+   (probeP:216) is *sufficient*, not necessary, and it is the expensive
+   branch. `PiHeadNorm` follows instead from Church–Rosser plus the
+   **standardization theorem**, and Theory already proves standardization in
+   full — `VEnv.ParRedS.standard`, `HeadReduction.lean:489`, after Kashima
+   (2000). Machine-checked: `LRS.PiHeadNorm.of_crLadder`.
+2. **Theory already has the target statement.**
+   `VEnv.IsDefEq.reduce_forallE` (`HeadReduction.lean:512`) *is*
+   `LRS.PiHeadNorm`, transposed to `VExpr`, and it is proved by exactly the
+   route in (1). Nobody in `plans/` had connected these; §3 does.
+3. **The real wall is sort inversion, not normalization.** `reduce_forallE`
+   consumes `IsDefEqU.sort_forallE_inv` and `IsDefEqU.sort_inv`
+   (`HeadReduction.lean:523`, `:527`; both `sorry` at `Injectivity.lean:34`,
+   `:11`). The probe localises this exactly: `LRS.NormalEqPiInvL` is
+   structural in six of `NormalEq`'s eight constructors, and the two
+   survivors, `etaL` and `proofIrrel`, cost precisely two sort facts
+   (`LRS.PiNotFunTyped`, `LRS.PiNotProof`).
+4. **That cost is unavoidable, by any route.** `LRS.PiHeadNorm` entails
+   `LRS.SortForallEDisj` in four lines, with no `PiHeadStable` detour
+   (`LRS.SortForallEDisj.of_piHeadNorm`). So **L4L-18A′ can never close the
+   16C′ leaf on its own**, whatever it is scoped to include.
+5. **`TypeWHNFEx` on its own unblocks nothing.** Its only consumer is
+   `PiHeadNorm.of_parts`, which also demands `PiHeadStable` — and
+   `PiHeadStable` already entails `SortForallEDisj`
+   (`LRS.SortForallEDisj.of_piHeadStable`). The recorded split therefore
+   divides the leaf's cost into a normalization half that is **avoidable**
+   and a sort half that is **not**.
+6. **Net re-scope.** 18A′ = confluence + standardization + the two `.extra`
+   overlaps + the live `Params`/`Params.Extension` instances, delivering
+   `SubjectRedS`, `PiEdgeInv` and `PiHeadNorm` *conditional on a named
+   four-field shape-disjointness interface*. A new micro-milestone (§9,
+   "16C″") owns that interface. **Estimated 8–14 serial developer-weeks, or
+   20–34 staged agent-sessions across four independent tracks.**
+
+---
+
+## 1. The `TypeWHNFEx` recommendation
+
+**Recommendation: do not prove `TypeWHNFEx`. Remove it from the critical
+path.** None of the three routes the commission offered is the answer; the
+answer is a fourth, (d) *avoid the decomposition that introduces it*.
+
+### 1.1 Why it is avoidable
+
+`LRS.PiHeadNorm` asks: given `Γ ⊢ X ≡ Y : .sort s` and `Γ ⊢ X ⤳* Πab`,
+show `Y ⤳*` some Pi. `PiHeadNorm.of_parts` reaches this by first
+manufacturing *some* weak-head normal form of `Y` (`TypeWHNFEx`) and then
+constraining its shape (`PiHeadStable`). But the Pi that `Y` must reach can
+be *transported* rather than manufactured:
+
+| step | instrument |
+|---|---|
+| `X ⤳* Πab` ⟹ `X ≫* Πab` | `WHRedS.parRedS`, SExpr:4252 (proved) |
+| `X ≡ Y` ⟹ `X ≫* X′`, `Y ≫* Y′`, `X′ ≡ₚ Y′` | Church–Rosser |
+| a `≫`-reduct of a Pi is a Pi | `ParRedS.forallE_inv` — **proved in probe** |
+| a `NormalEq` opposite a Pi has a Pi on the other side | `LRS.NormalEqPiInvL` (§4) |
+| `Y ≫* ` a Pi ⟹ `Y ⤳* ` a Pi | **standardization** |
+
+No step asserts that a normal form *exists*; the last step converts a
+normal form that has already been produced by transport into a weak-head
+one. Machine-checked as `LRS.ReduceForallE.of_ladder` and
+`LRS.PiHeadNorm.of_crLadder`, both `[propext, Quot.sound]`.
+
+This is not a new idea — it is precisely how Theory discharges the same
+statement at `HeadReduction.lean:511-530`. The probe's proof is that proof,
+with the two sort appeals factored out instead of spent inline.
+
+### 1.2 Verdicts on the three offered routes
+
+| route | verdict | reason |
+|---|---|---|
+| (a) an independent, smaller logical relation (a reducibility predicate not carrying adequacy) | **rejected** | This is a normalization proof for the full theory — universes, eta, proof irrelevance, *and* an abstract class of registered rewrite rules. `Params` (SExpr:26, ChurchRosser:18) imposes no termination, well-foundedness or orthogonality condition on `Pat`; `Params.Extension.join` requires only typed *joinability*. So the statement is not even determined by the interface: it would first need a new `Params` field constraining the rewrite system, and then a research-grade formalization on top. |
+| (b) full CR/standardization machinery | **does not deliver it** | Confluence and standardization are both *conditional* — they relate reduction sequences that exist. Neither produces one. Theory's `ParRedS.standard` needs a `≫*` sequence as input. |
+| (c) cheaper for types specifically | **no** | The claim is about `X` with `Γ ⊢ X : .sort s`, but nothing restricts the *shape* of such an `X`: it can be any application whose head is a type-valued constant. Deciding whether it has a weak-head normal form is deciding whether that application's iota/registered chain terminates. Types are not a syntactically simpler class here. |
+| (d) **do not prove it** | **recommended** | §1.1. |
+
+### 1.3 The reason the existing logical relation cannot be reused
+
+The commission notes that using `LogRel`/`LR` for `TypeWHNFEx` is circular.
+That is right, and the mechanism is worth recording. `LRS.ValTyPi2`
+(SLR:10221) *does* carry a weak-head-normal-form existence conjunct —
+`Γ ⊢ M₁ ⤳* .forallE B₁ F₁` — but only for a type already known to inhabit
+a `forallE` `WShape`. Getting an arbitrary well-typed type into the
+relation is exactly adequacy, which is what the leaf is trying to prove. So
+the relation supplies the existence claim only *after* the thing it is
+being used to establish.
+
+### 1.4 Consequence for the three obligations flagged mid-pass
+
+The coordinator reports that `LR.FixedHeadConvertStep` unfolds to
+`PiHeadNorm`, and that `∀ depth, LR.SelfAdequateDefeqStepAt` is also blocked
+on `PiPathInv`. Both are covered by §1.1 **provided** they unfold to
+`PiHeadNorm` and not to the strictly stronger conjunction
+`TypeWHNFEx ∧ PiHeadStable`. Those are different propositions: the
+conjunction implies `PiHeadNorm`, not conversely, and this pass supplies a
+proof of the former only. **Action for the ADQ owner:** check which of the
+two `FixedHeadConvertStep` actually needs. If it needs the conjunction, ask
+whether its consumer can be weakened to `PiHeadNorm` — every use this pass
+inspected can be.
+
+---
+
+## 2. Corrections to the recorded analysis
+
+| record | correction |
+|---|---|
+| `SExpr.lean:4371` — "nothing on the L4L-16 gate path consumes it" (`CRDefEq.trans`) | **False.** `LRS.PiPathInv.of_crLadder` (probe, Part 4) consumes `LRS.CRComplete`, whose Theory witness `IsDefEq.church_rosser` is proved from `CRDefEq.trans`; and `LRS.PiPathInv` is the sole residual of the 16C′ leaf. Recorded as the type-checked `LRS.crDefEq_is_on_the_gate_path`. |
+| `roadmap.md:735-741`, `:828` — 18A′ "must be scoped to include normalization" | **Withdraw.** §1. Normalization is neither necessary nor obtainable; standardization is necessary and is already proved. |
+| `roadmap.md:735` — "CR alone buys only `PiEdgeInv`, one of the two factors already recoverable" | **Understated.** CR + standardization buys `PiHeadNorm` as well, i.e. all three factors — modulo shape disjointness (§4). |
+| `plans/l4l-16-weakn-design.md:36-45` — HeadReduction.lean "has **no sorries** — but is tainted: its four `weak'_iff` uses ride on the target sorry" | **Correct but incomplete.** It is tainted a second, independent way: `reduce_sort` (:497, :502, :506) and `reduce_forallE` (:523, :527) consume `Injectivity.lean`'s `sort_inv` and `sort_forallE_inv`, and everything downstream of `church_rosser` inherits ChurchRosser's two `sorry`s. |
+| probeP:41 — `LRS.PiHeadNorm` "contains `IsDefEqU.sort_forallE_inv` … via `LRS.SortForallEDisj.of_piHeadStable`" | **Strengthened.** It contains it *directly*, with no `PiHeadStable` in between: `LRS.SortForallEDisj.of_piHeadNorm`. The obligation is on the leaf, not on the decomposition. |
+
+---
+
+## 3. Existing-machinery inventory
+
+### 3.1 `Lean4Lean/Theory/Typing/ChurchRosser.lean` — 1999 lines, **2 `sorry`**
+
+The complete Church–Rosser development on `VExpr`, and it is nearly done.
+
+Proved: `StructEq` (:137) and its full lemma set; `NormalEq` (:184) with
+`defeq`/`symm`/`weakN`/`instN`/`defeqDFC`/`weakN_inv_DFC`/`trans` (:860);
+`ParRed` (:943), `CParRed` (:964), `ParRed.instN` (:1002), `ParRed.defeq`
+(:1031), `ParRed.hasType` (:1058), `ParRed.weakN_inv` (:1129),
+`CParRed.exists` (:1204), **`ParRed.triangle` (:1253)** — 160 lines, the
+complete-development diamond, `.extra` case included — `ParRed.church_rosser`
+(:1413), `ParRedS` + congruence/substitution lemmas (:1421-1493),
+`ParRedExt` and `parRed_beta` (:1495-1717), `NormalEq.parRedS` (:1854),
+`ParRedS.church_rosser` (:1870), `CRDefEq.trans` (:1907),
+`IsDefEq.church_rosser` (:1952).
+
+**Sorried:** exactly two, both inside `VEnv.NormalEq.parRed` (:1747):
+
+* `:1759` — `constDF` meets `ParRed.extra`;
+* `:1778` — `appDF` meets `ParRed.extra`.
+
+These are the historical L4L-18A obligations, and they are the only `sorry`
+tokens in the file (single allowlist row, `Audit/SorryFrontier.lean:175`).
+The template for both already exists in the same file: `ParRed.triangle`'s
+own `.extra` case (:1253-1412), and `StRed.triangle`'s (`HeadReduction.lean:441-479`).
+
+**Assumed, not sorried** — and this matters for scoping:
+
+* `class Params` (:18) carries four *oracle* fields beyond the pattern
+  combinatorics: `structEta_weakN_inv` (:34), **`structEta_sort_disjoint`
+  (:54)**, **`structEta_forallE_disjoint` (:61)**, `forallE_weakN_inv`
+  (:71). The two bolded ones are shape-disjointness facts of exactly the
+  kind §4 identifies as the wall.
+* `class Params.Extension` (:1930) — the registered-equation join oracle,
+  consumed by `IsDefEq.church_rosser`. The roadmap already assigns its live
+  instance to 18A′ (`roadmap.md:859-863`); L4L-18B (complete, 2026-08-12)
+  built its proof-carrying interface.
+* `Params.henv : env.WF`, strictly stronger than SExpr's
+  `Params.henv : env.Ordered` (`VEnv.WF.ordered`, `EnvLemmas.lean:88`, is
+  one-way). An instantiation gap — see §7.
+
+### 3.2 `Lean4Lean/Theory/Typing/HeadReduction.lean` — 721 lines, **0 `sorry`**, tainted
+
+The single most under-used file in the repository for this problem.
+
+* `WHRed` (:59), `WHNF` (:141), `WHRedS` (:225) — the same relations SExpr
+  re-declares at SExpr:3762/3811/4030.
+* **`StRed` (:302)** — standard reduction, and its inversion lemmas
+  `sort_l` (:322), `lam_l` (:326), **`forallE_l` (:332)**.
+* **`StRed.triangle` (:418)** — 62 lines including the full `.extra` case.
+* **`ParRedS.standard` (:489)** — *the standardization theorem*, three lines
+  from `triangleS`. Header (:7-9) cites Kashima (2000). **This is the rung
+  that replaces normalization**, and it is already done.
+* **`IsDefEq.reduce_sort` (:493)** and **`IsDefEq.reduce_forallE` (:512)** —
+  head normalization of a definitional equality at the two rigid type heads.
+  `reduce_forallE` *is* `LRS.PiHeadNorm`.
+
+Taint, three independent sources:
+
+1. via `IsDefEq.church_rosser` — ChurchRosser's two `sorry`s;
+2. **`sort_forallE_inv` at :502 and :523, `sort_inv` at :506 and :527** —
+   `Injectivity.lean:34` and `:11`, both `sorry`. This is §4's wall and was
+   not previously recorded;
+3. four `weak'_iff` uses (:110, :112, :599, :603) riding on
+   `UniqueTyping.lean:174` (`sorry`), per `l4l-16-weakn-design.md:36-45`.
+
+### 3.3 `Lean4Lean/Theory/Typing/Injectivity.lean` — 34 lines, **3 `sorry`**
+
+Module docstring: "A bunch of important structural theorems which we can't
+prove :(". `IsDefEqU.sort_inv` (:11), `IsDefEqU.forallE_inv_stratified`
+(:16), `IsDefEqU.sort_forallE_inv` (:34). `IsDefEqU.forallE_inv` (:23) is
+*proved* from `forallE_inv_stratified`. `sort_inv` is the declared L4L-16
+gate theorem (`plans/l4l-16-sort-inversion-decision.md:15-22`).
+
+### 3.4 `Lean4Lean/Experimental/SExpr.lean` — the partial port
+
+| declaration | line | ported | missing |
+|---|---|---|---|
+| `ParRed` | 4079 | `rfl`, `weak'` | `instN`, `defeq`, `hasType`, `defeqDFC`, `apply_pat`, `weakN_inv`, `CParRed`, `triangle`, `church_rosser` |
+| `ParRedS` | 4111 | `weak'` | `hasType`, `defeq`, `app`/`lam`/`forallE`, `inst`, `church_rosser`, `standard` |
+| `NormalEq` | 4274 | `defeqDFC`, `defeq`, `symm`, `weak'` | `instN`, `trans`, `parRed`, `parRedS`, and the whole `structural`/`StructEq` constructor, which SExpr's `NormalEq` **does not have** |
+| `CRDefEq` | 4352 | `normalEq`, `refl`, `defeq`, `symm`, `defeqDF`, `weak'` | **`trans`** (deliberately absent, :4371) |
+| `StRed` | — | — | **entirely absent** |
+
+SExpr's own four `sorry`s: `WHRed.weakU_inv`'s `.extra` case (:3810),
+**`WHRedS.defeq` (:4033)**, `InferType.hasType` (:4136),
+`InferTypeS.hasType` (:4202). The probe shows the second is not separate
+work: `LRS.SubjectRedS.of_parRedSDefeq` derives it from `ParRedS.defeq`.
+
+### 3.5 The parked Experimental modules — both dead
+
+* `Lean4Lean/Experimental/NormalEq.lean` — 512 lines, **0 `sorry`**, header
+  line 4: "TODO: remove, this is now part of ChurchRosser.lean". Superseded.
+* `Lean4Lean/Experimental/ParallelReduction.lean` — 11 lines, **0 `sorry`**,
+  an import-compatible stub; its docstring says the maintained CR
+  development supersedes it and it has no consumers.
+
+Neither contains anything 18A′ needs. **Recommend deleting both** at the
+next cleanup boundary; they cost audit surface and mislead the map.
+
+---
+
+## 4. The wall, precisely
+
+Not normalization. **Head-shape disjointness**, of which sort inversion is
+the headline instance.
+
+### 4.1 Where it bites
+
+`LRS.NormalEqPiInvL` — invert a `NormalEq` whose right endpoint is a Pi —
+is structural in six of `NormalEq`'s eight constructors: `appDF`, `lamDF`
+and `etaR` put a non-Pi node on the right and die by `cases`; `refl` and
+`forallEDF` put a Pi on the left and succeed; `defeqDF` recurses. Machine-
+checked as `LRS.NormalEqPiInvL.of_parts`. The two survivors are:
+
+* **`etaL`**, whose right endpoint is an arbitrary `e'` carrying
+  `Γ ⊢ e' : .forallE A B`. Refuted exactly by "a Pi is not typed at a Pi" —
+  `LRS.PiNotFunTyped`.
+* **`proofIrrel`**, whose right endpoint is an arbitrary `h'` carrying
+  `Γ ⊢ h' : p` with `Γ ⊢ p : .sort .zero`. Refuted exactly by "a Pi is not
+  a proof of a proposition" — `LRS.PiNotProof`.
+
+Theory spends `sort_forallE_inv` and `sort_inv` on precisely these two
+(`HeadReduction.lean:523`, `:527`).
+
+### 4.2 Why confluence cannot supply it
+
+Confluence sees through everything that is a *reduction*. `proofIrrel` is
+not one: it is a congruence with no operational content, present in both
+`IsDefEq` (SExpr:1276) and `NormalEq` (SExpr:4288). Chasing the residue
+does not descend. Unfolding the obligation "no sort is a proof of a
+proposition" via unique typing produces `Γ ⊢ .sort v : .sort .zero` for a
+successor level `v`; unfolding *that* the same way reproduces a statement of
+the same form at a level determined by the previous one, with no decreasing
+measure — the regress has a fixpoint, not a base case. Refuting it requires
+a model in which `Prop` is not a universe containing `Type 0`. That is what
+`plans/l4l-16-sort-inversion-decision.md` already decided (route: shape
+logical relation), and it is L4L-16's gate theorem, not 18A′'s.
+
+### 4.3 Why it is unavoidable, not an artifact of this route
+
+`LRS.SortForallEDisj.of_piHeadNorm`, four lines, machine-checked: apply
+`PiHeadNorm` to the edge `Γ ⊢ .forallE A B ≡ .sort u : .sort s` with the
+reflexive reduction on the left; `.sort u` is already a weak-head normal
+form (`WHNF.sort`), so its only `⤳*`-reduct is itself, and the conclusion
+demands it be a Pi.
+
+So **any** proof of `LRS.PiHeadNorm`, by any route, proves sort/Pi
+disjointness on the way. `PiHeadNorm` is a factor of `LRS.PiPathInv`
+(probeP:303), which is the 16C′ leaf. Therefore **L4L-18A′ can never close
+the 16C′ leaf on its own.** That verdict is independent of how 18A′ is
+scoped and is the single most sequencing-relevant fact in this pass.
+
+### 4.4 The four shape facts 18A′ consumes and does not produce
+
+| fact | where consumed | current status |
+|---|---|---|
+| `IsDefEqU.sort_inv` | HeadReduction:506, :527 | `Injectivity.lean:11`, `sorry`; L4L-16 gate theorem |
+| `IsDefEqU.sort_forallE_inv` | HeadReduction:502, :523 | `Injectivity.lean:34`, `sorry` |
+| `Params.structEta_sort_disjoint` | ChurchRosser:54, used at HeadReduction:503 | oracle field of `Params` |
+| `Params.structEta_forallE_disjoint` | ChurchRosser:61, used at HeadReduction:524 | oracle field of `Params` |
+
+All four say the same kind of thing: two rigid head shapes are not
+definitionally equal. All four are what a shape logical relation delivers.
+Collecting them into one named class is the interface 18A′ should be built
+against — see §9.
+
+---
+
+## 5. The staged ladder
+
+Every rung is a Lean statement. Probe-verified rungs give their probe name;
+the rest are stated here for the implementer and are **not** machine-checked
+by this pass. "Serial after" gives the dependency.
+
+| # | rung | statement / probe name | difficulty | discharged by | serial after | parallel? |
+|---|---|---|---|---|---|---|
+| R0 | `ParRed`/`ParRedS` inversion at Pi and sort | `ParRed.forallE_inv`, `ParRed.sort_shape_inv`, `ParRedS.forallE_inv`, `ParRedS.sort_shape_inv` | **done** | this probe, `[propext, Quot.sound]` | — | ✔ |
+| R1 | Theory `Params` instance from SExpr `Params` | needs `env.WF` (SExpr has `Ordered` only) + the four oracle fields | **real work**; two fields are §4.4 semantics | partly `Params.Semantic` (SExpr:1964); disjointness fields → 16C″ | — | ✔ NOW |
+| R2 | weak-head reduction reflection, `mk`-ward | `VEnv.WHRedS (Γ.map reify) e.reify P → ∃ P', P = P'.reify ∧ WHRedS Γ e P'` | **real work**, mechanical | pattern bridges exist: `Pattern.MatchesS.reify` (SExpr:965), `Pattern.RHS.mk_apply_reify` (SExpr:1028), `mk_reify` (SExpr:299) | — | ✔ NOW |
+| R3 | the two `.extra` overlap cases | `VEnv.NormalEq.parRed`, ChurchRosser:1759, :1778 | **real work** (the historical 18A) | template: `ParRed.triangle`'s `.extra` case (ChurchRosser:1253-1412), `StRed.triangle`'s (HeadReduction:441-479) | — | ✔ NOW |
+| R4 | live `Params.Extension.join` | ChurchRosser:1930 | **real work**, overlaps L4L-16F "live instance" | L4L-18B interface (complete) | — | ✔ NOW |
+| R5 | `LRS.CRComplete` | `IsDefEq.church_rosser` transported | **consumption** | R1+R2+R3+R4 | R1–R4 | serial |
+| R6 | `LRS.PiStandard` | `ParRedS.standard` ∘ `StRed.forallE_l`, transported | **consumption** — already proved upstream | R1+R2 | R1,R2 | serial |
+| R7 | `LRS.ParRedSDefeq`, hence `LRS.SubjectRedS` | `ParRedS.defeq` (ChurchRosser:1431) transported; `LRS.SubjectRedS.of_parRedSDefeq` **proved in probe** | **consumption** | R1+R2 | R1,R2 | serial |
+| R8 | `LRS.PiNotFunTyped`, `LRS.PiNotProof` | §4.4 | **research-grade — NOT 18A′** | 16C″ (§9) | — | ✔ separate track |
+| R9 | `LRS.NormalEqPiInvL` | `LRS.NormalEqPiInvL.of_parts` — **proved in probe** | **consumption** | R8 | R8 | serial |
+| R10 | `LRS.ReduceForallE`, `LRS.PiHeadNorm` | `LRS.ReduceForallE.of_ladder`, `LRS.PiHeadNorm.of_crLadder` — **both proved in probe** | **consumption** | R5+R6+R7+R9 | R5,R6,R7,R9 | serial |
+| R11 | `LRS.PiEdgeInv` from CR | `NormalEq` Pi/Pi component extraction (the `forallEDF` case yields component `NormalEq`s) + `ParRedS.defeq` on components + path composition | **short proof** — *sketch only, not machine-checked* | R5+R7+R9 | R5,R7,R9 | serial |
+| R12 | `LRS.PiPathInv` — the 16C′ leaf | `LRS.PiPathInv.of_crLadder` — **proved in probe** from R7+R5+R6+R8+R11 | **consumption** | R10+R11 | R10,R11 | serial |
+
+**Attackable now, in parallel: R1, R2, R3, R4** — four independent tracks
+with no dependency on each other or on the sort facts. **R8 is a fifth
+track and belongs to a different milestone.** Everything from R5 down is
+consumption or short glue: once R1–R4 land, R5–R7 and R9–R12 are days, not
+weeks, and eight of the twelve rungs are already machine-checked here.
+
+**What `TypeWHNFEx` alone would unblock: nothing on this ladder.** It
+appears in no rung. Its only route to a consumer is `PiHeadNorm.of_parts`,
+which also demands `PiHeadStable` — R8-strength semantics. See
+`LRS.typeWHNFEx_not_needed` in the probe.
+
+---
+
+## 6. Implementation route: transport, do not port
+
+Two ways to get the Theory development onto the SExpr statement language.
+
+**Route B — port.** Re-prove ChurchRosser + HeadReduction on `SExpr`.
+Roughly 1600 lines to port (ChurchRosser:943-1912 ≈ 970; the `NormalEq`
+lemma block ≈ 430; HeadReduction's `StRed`+`triangle`+`standard` ≈ 230),
+*plus* adding the `structural`/`StructEq` constructor that SExpr's
+`NormalEq` lacks entirely (≈ 300). **Not recommended.**
+
+**Route A — transport via `reify`.** SExpr already has the bridge:
+`IsDefEq.reify` (SExpr:2876), `Ctx.WF.reify` (:2986), `mk_reify` (:299),
+`Pattern.MatchesS.reify` (:965), `Pattern.RHS.mk_apply_reify` (:1028), and
+`IsDefEqStrong.mkS` (:2091) in the other direction. What is missing is only
+R1 (the `Params` instance) and R2 (reflecting `WHRedS` back through `mk`,
+using `mk ∘ reify = id`). **Recommended**; it is what makes R5–R7 pure
+consumption and is why the ladder is as short as it is.
+
+Note that SExpr does *not* currently import `ChurchRosser`/`HeadReduction`
+(it stops at `Lemmas`, `Pattern`, `Strong`), so Route A implies a new import
+edge `SExpr.lean → HeadReduction.lean`. **Verified acyclic**: no file under
+`Lean4Lean/Theory/` imports anything under `Lean4Lean/Experimental/`, and
+`ChurchRosser` imports only `Pattern`, `Strong`, `UniqueTyping`. The edge
+does, however, pull ChurchRosser's two `sorry`s and `Injectivity`'s three
+into SExpr's transitive closure — so the audit frontier must be re-measured
+when it lands, and `Audit/SorryFrontier.lean` will need the SExpr-side rows
+re-checked.
+
+---
+
+## 7. Effort estimate
+
+### 7.1 Serial developer-weeks: **8–14**
+
+| rung | weeks | driver |
+|---|---|---|
+| R1 `Params` instance | 1–2 | the `Ordered`→`WF` upgrade, plus wiring the four oracle fields to their producers |
+| R2 `WHRedS` reflection | 1–2 | four constructors; only `extra` is non-trivial, and its bridges exist |
+| R3 the two `.extra` overlaps | 2–4 | the genuine unknown; two working templates exist in-repo |
+| R4 live `Params.Extension.join` | 2–4 | the generated-environment bridge; overlaps L4L-16F |
+| R5–R7, R9–R12 | 1.5–2 | consumption and glue; 8 of 12 rungs already checked |
+
+Assumptions driving this number: one developer, no parallel tracks; R3
+behaves like the already-finished `ParRed.triangle`/`StRed.triangle`
+`.extra` cases, i.e. the existing pattern non-overlap interface suffices and
+**no new `Params` field is required**. If R3 needs a new field, add 2–4
+weeks — and check whether the new field is another §4.4 semantic oracle, in
+which case it belongs to 16C″ and this estimate is the wrong shape.
+**Excludes R8 entirely.**
+
+### 7.2 Staged parallel agent-sessions: **20–34**
+
+Calibrated against the repository's one published pair — `weakN_iff`, 2.5–5
+serial weeks ↔ 8–11 staged sessions (`l4l-16-weakn-design.md:268-282`) —
+which is 2.2–3.2 sessions per serial week.
+
+Assumptions driving this number, and they differ from §7.1's: R1/R2/R3/R4
+run as four concurrent tracks from day one (they share no file and no
+lemma); each session is scoped to one named Lean statement with its own
+probe; and the repeated observation that a probe-first session lands
+200–400 lines. Wall-clock is then set by the longest track, R3 or R4, at
+roughly 6–13 sessions each — so **the 5–10× advantage here is in wall-clock
+and re-work, not in total session count**, and it is realised only if R1–R4
+are genuinely dispatched in parallel. Dispatching them serially forfeits it
+and reproduces §7.1.
+
+---
+
+## 8. Sequencing recommendation
+
+### 8.1 18A′ *with* 16C′, not before it
+
+They share no files — 18A′ is `Theory/`, 16C′ is `Experimental/` — and the
+dependency between them is one-way *at the interface level only*. Run them
+concurrently. But note the real shape of the dependency, which is not what
+the roadmap currently records:
+
+* 16C′ needs `PiPathInv`, which 18A′ supplies (R12);
+* 18A′ needs the four shape facts (§4.4), which **only the semantics can
+  supply** (§4.2);
+* those facts currently come out of adequacy
+  (`TypeDefEqPath.sort_inv_of_adequacy`, ADQ:109; the `sortInv` fields at
+  ADQ:451/471/493 and `sort_inv_of_adequacyAtDepth`, ADQ:522), and adequacy
+  is what needs `PiPathInv`.
+
+**The decisive open question, and it belongs to the ADQ owner, not to
+18A′:** *can adequacy deliver the §4.4 shape facts at a rung strictly below
+the one that consumes `PiPathInv`?* If yes, the ladder is acyclic and 18A′
+closes the leaf. If no, there is a genuine cycle and the project needs a
+third input. Note the encouraging asymmetry: `sortInv` already has a
+**depth-indexed** producer (ADQ:471, :493, :522) whereas probeS closed the
+depth-indexed route for `PiPathInv` — so the two may well separate. That is
+the next thing to check, and it is cheap to check.
+
+### 8.2 Cut 16C″ — "shape disjointness"
+
+A new micro-milestone whose sole deliverable is the four §4.4 facts as one
+named class, proved from the shape logical relation independently of
+`PiPathInv`. It is far smaller than full adequacy: it needs only the
+*soundness* direction (read a shape off a derivation), not the reflection
+direction that makes adequacy hard. It is the true blocker for both 16C′
+and 18A′, and today it is nobody's milestone.
+
+### 8.3 Re-cut 16C′ to close conditionally — **yes, do it**
+
+The commission asks honestly whether closing 16C′ with the leaf conditional
+on a named CR-supplied Prop is worth doing when the sorry moves rather than
+disappears. It is, for four reasons, and the cost is nearly zero:
+
+1. **It is nearly free.** `LRS.PiPathInv` is *already* threaded as an
+   explicit hypothesis, not embedded in an induction —
+   `SpineWF.result_path (piInv : LRS.PiPathInv)` (SLR:11348),
+   `WHRedS.defeq_of_piPathInv` (SLR:11464),
+   `LRS.constSpineTypeUniqPath` (SLR:11373). Closing conditionally is
+   plumbing, not restructuring.
+2. **It collapses three obligations into one import.** `PiPathInv` now
+   gates `MajorChainAnchorStep`, `LR.FixedHeadConvertStep` and
+   `∀ depth, LR.SelfAdequateDefeqStepAt`. One named interface serves all
+   three.
+3. **It makes the residual auditable.** A single named `Prop` in
+   `SorryFrontier` beats a structural gap inside an induction.
+4. **It unblocks the rest of the ladder.** 16D/16E can proceed to green
+   against the interface.
+
+The one thing to get right: make the named Prop the **shape-disjointness
+class of §4.4**, not `PiPathInv` itself. `PiPathInv` is 18A′'s *output*;
+the disjointness class is the genuine leaf, it is what 16C″ owes, and
+conditioning on it keeps the two milestones' interfaces honest.
+
+### 8.4 What 16C′ banks meanwhile
+
+Everything already landed stays banked and is unaffected by this pass: the
+depth tower (`contextualAdequacyAtDepth_of_iotaSteps`),
+`SelfAdequateConstStep`, `CoherentFixedHeadStep`, the chain-wall repair
+(`to_core_path`, `CtorRetype`, `CtorSpineTypeUniqPath`, SLR:11112-11147),
+and `MajorChainAnchorStep`. Still bankable without any 18A′ input:
+`CoherentIotaLeafStep`, `ConstDefnLocalStep`, the δ-definition residual
+(`ConstDefnDeepStepR`/`ConstDefnDeepInstStep`),
+`∀ depth, FixedHeadTypeValidStep`, and `FixedHeadTerminalRetarget`.
+
+### 8.5 Roadmap edits this implies
+
+* Retitle the ladder entry `L4L-18A` → `L4L-18A′` and rewrite `:824-836`
+  per §0 and §2 (strike normalization; add standardization as *already
+  proved*; correct the "CR alone buys only `PiEdgeInv`" clause).
+* Add `L4L-16C″` before 16C′ in the ladder.
+* `plans/roadmap.md:741` and `:833` cite this file; both now resolve.
+* Tracked-file bookkeeping: `.gitignore` ignores `/plans/*` with per-file
+  `!` negations, and `roadmap.md:9-17` lists the tracked set by name. If
+  this doc is meant to travel with checkpoints, both need an entry. **Not
+  done by this pass** — outside the assigned territory.
+
+---
+
+## 9. Appendix — probe evidence
+
+Command (run from the repository root):
+
+```
+lake env lean plans/probes/probeCR-scope.lean
+```
+
+Full output, exit 0:
+
+```
+'Lean4Lean.SExpr.LRS.SortForallEDisj.of_piHeadNorm' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.SortForallEDisj.of_piHeadStable' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.typeWHNFEx_not_needed' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.ParRed.forallE_inv' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.ParRed.sort_shape_inv' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.ParRedS.forallE_inv' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.ParRedS.sort_shape_inv' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.ReduceForallE.of_ladder' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiHeadNorm.of_reduceForallE' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiHeadNorm.of_crLadder' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.SubjectRedS.of_parRedSDefeq' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.NormalEqPiInvL.of_parts' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiPathInv.of_piEdgeObs' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiEdgeObs.of_parts' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiEdgeInvObs.of_parts' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.PiPathInv.of_crLadder' depends on axioms: [propext, Quot.sound]
+'Lean4Lean.SExpr.LRS.crDefEq_is_on_the_gate_path' depends on axioms: [propext, Quot.sound]
+```
+
+No `sorryAx`; no `Classical.choice`. Nothing in the probe is `sorry`ed. The
+three rungs stated but *not* machine-checked by this pass are R1, R2 and
+R11; R11 is a sketch in §5 and should be treated as unverified until a
+successor probe lands it.
diff --git a/plans/l4l-18b-extension-interface-design.md b/plans/l4l-18b-extension-interface-design.md
new file mode 100644
index 00000000..584080b9
--- /dev/null
+++ b/plans/l4l-18b-extension-interface-design.md
@@ -0,0 +1,180 @@
+# L4L-18B extension contract and pattern-interface design
+
+Date: 2026-08-12
+
+Status: implemented fork divergence on the reconciled v4.33 base. This note
+records the interface decision owned by ledger entry D020. Construction of a
+whole-live-environment semantic instance remains L4L-16 work.
+
+## Problem
+
+The upstream-shaped `Params` interface coupled two facts that do not hold at
+the same syntactic point in lean4lean:
+
+1. `extra_pat` required a `Pattern.Matches` witness for
+   `df.lhs.instL levels`.
+2. `pat_wf` accepted a pattern match, checks, and a bare typing of the redex,
+   then had to manufacture equality with the RHS template.
+
+Generated iota equations and `quotDefEq` are registered as closed lambda
+towers. A first-order iota pattern cannot match the tower itself. The useful
+recursor/constructor application appears only underneath the leading lambdas,
+after applying a typed spine and beta-collapsing the tower. The proved
+generated-rule soundness theorem consequently needs that typed spine
+decomposition; bare `HasType` does not contain it.
+
+Leaving either mismatch as a `Params` field would make a generated instance
+an oracle: registration or pattern membership could silently assert an
+operational rewrite that was not proved at the actual redex.
+
+## Decision: separate shape, local soundness, and global joining
+
+### Pattern combinatorics
+
+`Params` now contains only the pattern set and its combinatorial laws:
+simple-pattern classification and the overlap/nonintersection properties used
+by the parallel-reduction proofs. It has neither `pat_wf` nor `extra_pat`.
+
+Pattern membership therefore says only that a pattern and payload participate
+in the reduction system. It does not imply that any term matches, that checks
+hold, or that a rewrite is definitionally equal.
+
+### Proof-carrying contractions
+
+The `.extra` constructors of `ParRed`, `CParRed`, and `WHRed`, and the
+corresponding `NonNeutral` witness, carry the exact local certificate
+
+```lean
+IsDefEqU env univs Γ e (r.1.apply m1 m2)
+```
+
+in addition to pattern membership, the successful match, and `Check.OK`.
+Weakening, substitution, context conversion, standardization, and triangle
+proofs transport or reconstruct this certificate explicitly. `ParRed.defeq`
+uses the carried equality; it never obtains soundness from pattern
+classification.
+
+This makes the operational trust boundary local: the consumer selecting a
+contraction must prove equality for that concrete redex and capture map.
+
+### Beta-collapsed tower coverage
+
+`CertifiedExtension.covers` now states only the syntactic fact that the
+registered left side matches after its leading lambda tower is exposed:
+
+```lean
+∃ m1 m2, pat.toPattern.Matches
+  (VExpr.stripLams (df.lhs.instL levels)) m1 m2
+```
+
+`VExpr.stripLams_instL` and `Pattern.Matches.instL` make this stable under
+universe instantiation. They do not claim that the pattern payload's RHS is
+equal to the registered RHS.
+
+Two kernel-checked constructors pin the intended environment classes:
+
+- `BlockGenerationChecked.iotaExtension` derives coverage from the generated
+  rule body and `ruleLhsBody_matches` for every certified iota rule.
+- `CertifiedExtension.quot` gives the corresponding `Quot.lift`/`Quot.mk`
+  pattern, captures, checks, and collapsed coverage for `quotDefEq`.
+
+Both have exact axiom guards containing only the standard logical baseline;
+neither uses a project axiom or `sorryAx`.
+
+### Global registered-equation joining
+
+Church--Rosser's raw `IsDefEq.extra` case has a different obligation from a
+local pattern contraction. It is isolated in the explicit class
+
+```lean
+class Params.Extension [Params] where
+  join : OnCtx Γ (env.IsType univs) →
+    env.defeqs df → (∀ l ∈ levels, l.WF univs) →
+    levels.length = df.uvars →
+    CRDefEq Γ (df.lhs.instL levels) (df.rhs.instL levels)
+```
+
+`CRDefEq` includes typings for both endpoints and parallel-reduction paths to
+endpoints related by `NormalEq`. Thus an instance must prove operational
+coverage for every registered equation in every well-formed context; registry
+membership alone cannot inhabit it. `Params.Extension.extra_symm` derives the
+reverse direction from the join rather than adding a second oracle field.
+
+Only `IsDefEq.church_rosser` and results that transitively invoke it require
+`[Params.Extension]`. The remaining generic reduction and standardization
+lemmas stay generic in `[Params]` alone.
+
+The live-environment instance covering definitions, quotient rules,
+ordinary/mutual/nested inductives, and registered structure eta is deliberately
+not manufactured here. L4L-16 constructs it through the semantic environment
+bridge.
+
+## Environment transport
+
+The named `VEnv.LE` helpers make the core registered-equation behavior under
+environment growth explicit:
+
+- `VEnv.LE.extra` transports registry membership and reconstructs the raw
+  typed equality with the original level side conditions.
+- `VEnv.LE.extra_appN` additionally transports a typed spine and applies
+  congruence to both tower endpoints.
+- `VEnv.LE.extra_appN_symm` derives the reverse applied equality by symmetry.
+
+These theorems transport proofs already available in the smaller environment;
+they do not certify a new rule or infer a reduction from a pattern.
+
+## Trust matrix
+
+| Evidence | What it establishes | What it does not establish |
+|---|---|---|
+| `env.defeqs df` | the raw tower equation is registered | a pattern match or reduction step |
+| `CertifiedExtension.covers` | the stripped left body has the advertised shape | checks, typing, or equality to the payload RHS |
+| `Check.OK` | captured side conditions hold in the current context | redex-to-RHS equality |
+| local `IsDefEqU` certificate | this matched redex equals this instantiated payload | global confluence for every registered equation |
+| `Params.Extension.join` | a registered raw equation has a typed Church--Rosser join | automatic permission to contract an arbitrary match |
+
+No row implies a later row without a proof supplied by the corresponding
+consumer.
+
+## Downstream migration
+
+`ChurchRosser.lean` transports the local equality certificate through
+weakening, substitution, context conversion, complete parallel reduction,
+match inversion, and the triangle proof. `HeadReduction.lean` mirrors the
+same certificate in weak-head steps and reconstructs it in the
+standardization triangle. The broad extension-instance requirement was
+narrowed to `reduce_sort`, `reduce_forallE`, and `InferType.exists`, the three
+head-reduction results that actually invoke Church--Rosser.
+
+Later L4L-18A overlap proofs target the proof-carrying `.extra` constructor.
+Later L4L-16 constructs `Params.Extension` from the promoted semantic bridge;
+it may use the beta-collapsed certificates and `pat_wf`, but cannot replace
+their typing premises with registry membership.
+
+## Rejected alternatives
+
+- Matching the raw lambda tower: structurally false for the supported
+  first-order patterns.
+- Storing a collapsed RHS equation in `CertifiedExtension`: this conflates a
+  syntactic inventory certificate with semantic soundness and would still
+  omit the typed-spine premises.
+- Retaining `Params.pat_wf` with bare `HasType`: insufficient for the proved
+  generated-rule theorem and invites a consumer oracle.
+- Treating every registered equality as a reduction: equality registration
+  is symmetric conversion data, not an orientation or termination policy.
+- Generating a global `Params`/extension instance in the assembler: the
+  assembler covers one block plus explicit extensions, not the whole live
+  environment required by the semantic proof.
+
+## Validation and upstream path
+
+Focused builds cover Church--Rosser, head reduction, the pattern environment,
+and concrete pattern fixtures. Exact guards pin the new universe-match
+transport, generated-iota and quotient certificates, and `VEnv.LE` transport
+helpers. The full milestone gate is recorded in the landing checkpoint.
+
+D020 is revisited at every upstream reconciliation. It is removed when
+upstream adopts the proof-carrying contraction and explicit join split, or an
+equivalent interface that can represent beta-collapsed tower rules without a
+trusted shape/soundness oracle. Upstream review is consolidated in the
+L4L-20C proof-PR series.
diff --git a/plans/roadmap.md b/plans/roadmap.md
index 0692fcda..b31bb46a 100644
--- a/plans/roadmap.md
+++ b/plans/roadmap.md
@@ -1,12 +1,20 @@
 # Lean4Lean completion roadmap
 
-**Status:** authoritative local roadmap, audited 2026-08-07 against the
-committed fork and the current `jcb/formalization` development bookmark;
-publication to `jcb/induct` remains a separate boundary.
+**Status:** authoritative local roadmap, audited 2026-08-12 against the
+committed fork, the current `jcb/formalization2` development bookmark, and
+the uncommitted L4L-16 working copy; publication (moving
+`origin/jcb/formalization2`) is a separate boundary and currently matches
+the local bookmark at the L4L-18B checkpoint.
 
 **Versioning.** `plans/roadmap.md` is intentionally tracked so the
-status-bearing milestone ladder travels with each checkpoint; other files
-under `/plans` remain ignored. The root-level `upstream-divergence.md` is the
+status-bearing milestone ladder travels with each checkpoint, as are the
+design/decision notes the ladder references
+(`l4l-15-structure-eta-design.md`, `l4l-16-sort-inversion-decision.md`,
+`l4l-18b-extension-interface-design.md`, `l4l-16-completion-plan.md`,
+`l4l-16c-adequacy-log.md`, `l4l-16c-buildp-premortem.md`,
+`l4l-16d0-slice-map.md`); every other file under `/plans` remains
+ignored, and the tracked set is mirrored as explicit `.gitignore`
+negations. The root-level `upstream-divergence.md` is the
 tracked per-delta ledger and complements this roadmap. This document is
 forward-looking only: completed milestones are deleted from the ladder when
 they close, and their full narratives, hashes, and gate evidence live in this
@@ -67,277 +75,356 @@ required for the final release; they can be reached in separate milestones.
 
 | Fact | Value |
 |---|---|
-| Ladder position | **L4L-09A active**; L4L-08C and everything above it are complete and pruned from §5; everything below L4L-09A is queued |
-| Current formalization source | L4L-08C mutual generation/preservation/replay implementation through `aa10005d`, built on the L4L-08A checked representation `79e1ae4f` and L4L-08B validation semantics; this closure checkpoint adds the migration shim and completion audit at `jcb/formalization`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending |
-| Parent lineage | upstream-reconciliation merge `7f864b459e4a6062b468d6e5416688feac0f9f99` (second parent: digama `upstream/master` `ef849dfbd94a`); Lean and lean4-nix on v4.31 |
-| Fixed `master` baseline | `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` |
-| Trust frontier | exactly 20 live source `sorry` tokens across 19 proof declarations, plus six kernel-rejection recovery declarations (25 compiled allowlist entries total), and 29 custom-axiom declarations; all are pinned by exact audits |
-| Gates | the full §6 gate is green on the L4L-08C closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, all native flake checks, sorry-frontier and Theory import-boundary audits, formatter check, and whitespace check |
+| Ladder position | **L4L-16 active** (semantic environment bridge and sort inversion). L4L-18B completed first on 2026-08-12: proof-carrying pattern contractions, an explicit registered-equation join contract, beta-collapsed generated-iota/`quotDefEq` coverage, and `VEnv.LE` transport now form the fork-owned interface (design note `plans/l4l-18b-extension-interface-design.md`, ledger D020). The former L4L-17 merged in on 2026-08-13 (joint route; second resolution in the sort-inversion decision note). Slices 16A and 16B′ are complete at checkpoints `quyyrlks`/`pxluxmvm`; the WHNF/determinism layer and mirror-spine refactor landed at `wolxmups`/`mvmrxuus`; 16D0 is complete in the active working tree (`SExprParamsD0.lean`, D0a + definition-extended D0b, `d0SortInvS`); 16C′ joint leaf closure remains active (§5), with publication held until it measures clean |
+| Current formalization source | the L4L-18B checkpoint (jj change `oluxtqyk`) descends from the L4L-15B checkpoint `7c1e89fc` (jj change `xuzusmnl`) and is published at `jcb/formalization2` after the complete gate passed |
+| Parent lineage | the L4L-15B implementation descends from the v4.33 reconciliation merge `99a7f8ae7b89` (second parent: digama `upstream/master` `b292275c`); Lean on v4.33.0 final, lean4-nix on `argumentcomputer/lean4-nix` (upstream pins v4.33.0-rc2 — ledger D018) |
+| Fixed `master` baseline | `1a16b72d2e35932a82aa501beb29ef2c3d072580` — local `master` bookmark (corrected 2026-08-12; the row previously carried a fork formalization hash that no `master` ref ever pointed at). The v4.33 reconciliation merged the later digama `upstream/master` `b292275c` as its second parent without moving `master`; `origin/master` has since moved (see remote drift) |
+| Remote drift (re-verified 2026-08-14 via GitHub API; local `upstream/master` was never fetched past `b292275c`, so any reconcile begins with a fetch) | digama master is now **four** commits past the merged `b292275c`, tip `4b60e53d` (2026-08-14): stage-2 replay perf (clean-apply), the normalize-backed level-algorithm enable (half-absorbed — the fork independently made the `isEquivList` change in `99a7f8ae`; residue is the `geq'` flip inside `checkConstructors`), a proj-reduction restructure that conflicts with the fork's sorry-free `reduceProj.WF` (upstream's own version rests on a new sorry), and a neutral K-target reorder — checker-side work landing in L4L-19A/B territory; per-commit analysis and a defer-recommendation (reconcile as L4L-19's first action) in the local untracked note `plans/l4l-16-boundary-digama-drift.md`; the reconcile-or-defer decision remains due at the L4L-16 boundary (§7). `origin/master` moved one commit to `715bfaff` ("verify: prove soundness of the standard library normalize") — already an ancestor of the fork's formalization line (the `eval_normalize`/`eval_normalize_total` proofs are in-tree), so content is absorbed and only the ref recording changed |
+| Trust frontier | exactly 16 sorried proof declarations (10 Tier V, 6 Tier R; `NormalEq.parRed` carries two tokens) plus six kernel-rejection recovery declarations — 22 compiled allowlist entries — and 34 custom-axiom declarations; all are pinned by exact audits. L4L-15B removed the two structure-eta checker roots from the direct frontier; their inherited L4L-16--19 dependencies remain explicit in exact axiom guards |
+| Gates | the full §6 gate is green on this checkpoint: the 212-job default Lake build, the Nix flake checks, the 22-entry exact sorry frontier, the Theory-only import/axiom audit, downstream-consumer and CLI checks, and whitespace hygiene |
 
 ### 2.1 What is green
 
-**Theory.** Dependent `VInductDecl.Checked`/`checked?` analysis with
-environment-free closure/universe/name/anatomy checks and an
-environment-indexed `Checked.WF env` (including Lean's impredicative Prop
-exception `l = .zero ∨ u ≤ l`); the raw/view `Normalization source` boundary
-with computed `normalizationShape` and semantic `Normalization.WF env`;
-`NormalizedChecked` and `GenerationChecked` paired raw/view blocks; mixed
-motive/minor/recursor/rule generation that retains raw binder syntax while
-consulting the checked view for recursive classification, proved well formed
-through the complete ordered rule fold. The one-family transaction
-`VEnv.addInductGeneration` and its proof-carrying
-`GenerationCertificate`/`addInductCertified` boundary remain available.
-`BlockGenerationChecked` generalizes the same artifact path: it emits one
-motive and recursor per family, globally flattens constructor minors and rules
-in family/source order, and routes recursive hypotheses and rule calls by the
-checked target-family ordinal. `VEnv.addInductBlockGeneration` inserts all
-families, then all constructors, then all recursors, then all rules; its exact
-trace supplies atomicity, freshness, lookups/membership, monotonicity, and
-`Ordered` preservation through every phase. The raw public `addInduct` now
-selects this block descriptor without singleton projection. A deprecated
-`addInductSingleton` wrapper retains the former raw one-family transaction for
-the migration window without becoming a competing block path. The shared
-checked/generation artifact retains the exact K-target decision separately
-from its elimination mode. The slice covers parameters, per-family indices,
-direct and sibling recursion, recursive targets below Pi telescopes, small
-elimination, subsingleton large elimination, K-target metadata, and exact
-zero-/one-constructor generation.
-
-**Mutual validation, generation, and replay.** `VInductDecl.CheckedBlock` and
-`checkedBlock?` analyze an arbitrary nonempty `decl.types` list without
-singleton destructuring. Shared parameters are retained once, while
-`CheckedFamilies source params ordinal types` is indexed simultaneously by
-the exact remaining source-family list and its starting ordinal. Each
-`CheckedFamily` retains its per-family indices, result level, and ordered
-constructors; every `RecArg.targetType` is computed from the block-wide family
-header order, including targets beneath positive Pi telescopes. Block-family
-mentions are excluded from family formers, recursive domains, and recursive
-indices, and generated-name uniqueness is checked across all families,
-constructors, and future recursor names.
-
-`Normalization.BlockWF`, `CheckedBlock.WF`, `ValidatedBlock.WF`, and
-`ValidationCertificate` give the arbitrary-block representation an exact
-environment-indexed semantic package. Family validation retains shared
-parameter agreement and one semantic result universe, then all raw family
-constants are staged before constructor validation. The block constructor
-trace records every family/constructor/ordinary-field target in source order,
-including sibling recursion and recursion beneath Pi binders. The real
-Tree/TreeList and indexed IndexedTree/IndexedTreeList fixtures execute the
-ordinary kernel validators, compute the exact target matrices, and inhabit
-complete normalization, checked-block, and block-generation WF certificates.
-Their generated inventories have respectively two motives, five/four globally
-ordered minors, two recursors, and five/four rules. Exact kernel comparisons
-cover every `InductiveVal`, `ConstructorVal`, `RecursorVal`, and
-`RecursorRule` field represented by the Theory boundary, including constructor
-indices, block-wide recursion/reflexivity flags, recursor motives/minors/K,
-translated types in metadata universe order, rule ownership/field counts, and
-every RHS. Both raw `addInduct` and the proof-carrying block transaction produce
-the same final Theory environments. The four phase boundaries replay through
-`AddInductBlockTrace`, `TrEnv'.inductBlock`, and `Aligned.addInductBlock` to
-actual implementation `ConstMap`s, with exact final ordering, lookup, rule
-membership, and guarded trust closures. Exact negatives still pin the
-parameter-mismatch, result-universe-mismatch, and reordered-family validation
-phases, including host Lean diagnostics and transparent validator errors.
-
-**Kernel parity fixtures.** One integrated 14-row matrix covers Nat, Bool,
-List, Option, Prod, Unit (honestly represented by the kernel's `PUnit`), Empty,
-Or, And, Eq, HEq, Fin, Vector, and Acc. Every row reruns the ordinary producer
-and definitionally compares the stored family/constructor types in their
-metadata universe order, names, parameter/index/field counts, recursive rule
-metadata, elimination/K behavior, recursor type, rule count, and every iota
-RHS. The consolidated 32-row rejection matrix covers closure, internal and
-pre-existing name collisions, universe and result-shape failures, parameter
-and universe-count mismatches, raw/view incoherence, non-defeq normalization,
-nested negativity and illegal recursive targets, field-universe boundaries,
-and invalid elimination/K expectations. The earlier `IndexedVec` regression
-remains as a supporting indexed two-constructor fixture outside this fixed
-singleton inventory. `AliasFormer` and `AliasRec` prove normalization is
-necessary, not hypothetical: real metadata
-retains reducible aliases at the family result and around a recursive field;
-their raw declarations fail `checked?` while their certified views succeed.
-`NormalizationMatrix` closes the differential breadth for reducible aliases
-in family, parameter/index, ordinary-field, direct-recursive, and
-Pi-hidden-recursive positions, including retained beta/let bodies. Its exact
-kernel candidate succeeds at fuel 10 and fails at 9, opaque and non-defeq
-variants reject, and the actual family/constructor/recursor/rule metadata
-replays through the final aligned Theory environment.
-The edge fixtures additionally pin every `PUnit` and `Empty` inductive,
-constructor, and recursor metadata field, exact motive/minor/major order,
-zero-field recursive-argument data, rule counts, and every available iota RHS.
-They record `Unit` itself as the reducible `PUnit` definition metadata Lean
-actually supplies, rather than inventing alias-level inductive metadata.
-
-**Elimination and K-target parity.** The ordinary large-eliminator decision,
-elimination-level run, and independent K-target decision now retain exact
-operational traces, including inferred singleton field sorts, occurrence
-tests, the K constructor walk, the fresh elimination parameter, and both
-recursor level orders. Theory generation constructs both elimination modes and
-the K flag and is differentially aligned with those executions. Exact kernel
-fixtures pin `Eq` as K/large with fresh-first parameters `[u, u_1]`; `And` as
-non-K yet legitimately large through its singleton proof fields; `Or` and a
-source-universe-bearing family as non-K/small; and `Nat` as non-K/large through
-the never-zero branch. The source-universe fixture retains its source
-parameter without adding a fresh one. Their exact kernel K flags, recursor
-metadata, universe order, and every focused rule RHS match Theory generation.
-Verify's `RecursorKMatches` makes a type-correct recursor with the wrong K
-metadata fail environment alignment.
-The `PUnit`/`Empty` executions close the one-/zero-constructor boundary:
-`PUnit` traverses a singleton with no parameter, proof, or data fields and
-retains fresh-first recursor levels, while `Empty` takes the ordinary
-never-zero large-elimination branch with no singleton, minor, or rule. Both
-align with the shared checked generation and remain non-K.
-
-**Verify.** A checker-run certificate layer (`WhnfRun`, `CheckTypeRun`,
-`IsDefEqRun`, `DefEqEvidence`, `TelDefEqEvidence`, `NormalizedCtorRun`,
-`GenerationRun`) turns exact ordinary-checker executions into Theory typing
-and definitional equality through the existing refinement theorems. Level
-subsumption is evaluation-preserving for every raw `NormLevel`: active-path
-witnesses now guard constant removal, and the proof follows both nested map
-folds. Valid normalizer output remains unchanged under the differential audit;
-the theorem's exact closure is only `propext`, `Classical.choice`, and
-`Quot.sound`, with no project-specific axiom. Level equivalence soundness now
-closes the typechecker sort and dependent constant-level-list paths through
-the verified project comparator: a transparent structural fast path reflects
-equality, canonical ordered-entry comparison gives `NormLevel` evaluator
-congruence, and `isEquiv_wf` plus its list theorem have the same standard-only
-axiom closure. The executable normalizer is unchanged, and a generated
-differential compares the former map-extensional equality with ordered-entry
-equality across normalized zero, successor, max, imax, and parameter forms. The
-executable candidate producer (`AddInductive.normalizeCandidateExpr`,
-`buildNormalizationCandidate`) retains recursively context- and source-indexed
-traces with exact full-check/WHNF/binder-equality runs at every node,
-structurally certified annotation consumption (agreement with Lean's opaque
-`consumeTypeAnnotations` is runtime producer validation, never a semantic
-proof field), a `storedSpine` invariant, and arbitrary-length dependent
-`Produced` list witnesses. Semantic-hierarchy assembly is automatic under
-`Nonempty`; the consolidated generation-readiness gate plus exact dependent
-analysis and analyzer-owned view WF derive checked WF and every per-position
-shape record, so fixtures supply no component equations. The generic singleton
-closure combines that staged owner, the exact dependent analysis, and the
-produced generation shape into an exact package while deriving its public
-package; no caller supplies a view, view-WF proof, or per-component equation.
-The staged semantic-input owner, family-validation semantics with post-family
-staging, and the complete retained constructor-validation trace (with
-source-list inversion and phase-local failure theorems) are in place. The
-source-ordered constructor-universe audit admits structural order and the
-impredicative-Prop exception directly; its normalized non-Prop branch requires
-both Lean's unchanged core `Level.geq` decision and the verified project
-`geq'` decision. `NormLevel.le_eval` and `geq'_wf` prove the project half
-semantically, while the core half keeps every accepted audit node inside the
-ordinary validator's existing acceptance boundary. The exact proof closure is
-only `propext`, `Classical.choice`, and `Quot.sound`; an all-pairs mvar-free
-core/project differential covers zero, successor, max, imax, parameters, and
-nested combinations, and the former max/parameter exclusion is now a positive
-regression. The post-family constructor owner
-aligns the retained validator and candidate telescopes by source position,
-independent of their fresh-FVar identities, and interprets root, parameter,
-field, positivity, and terminal checks in the actual verified post-family
-context without claiming pre-family `fieldsWF`.
-The executable pre-family owner instantiates the retained family parameters
-and replays every analyzer-owned constructor in the exact verified pre-family
-context. Ordinary fields are rechecked and retained; recursive outer locals
-are omitted while nested Pi binders and recursive/result index spines receive
-verified semantic interpretations and proved prefix weakening. Independent
-ordinary fields may now follow an omitted recursive outer field and continue
-through the generalized semantic replay. The actual `ConstructorValidityMatrix`
-metadata now closes this path structurally across its two parameters and six
-fields: dependent data/proof fields, direct recursion, recursive-function
-recursion, and an independent dependent data/proof suffix after both omitted
-recursive locals. The proof derives the retained constructor-validation trace,
-universe run, post-family alignment, exact fresh-name independence, zero-index
-terminal spine, and final pre-family safety result without a stage-local
-decision oracle. Its guarded axiom closure contains only the pre-existing
-verified-checker frontier and the single exact L4L-01E producer-execution
-witness. `PropRecursiveBoundary` separately pins the impredicative-Prop branch
-with recursive-function and index structure. Nearest-kernel negatives reject
-nested negativity, family occurrences in nonrecursive and proof fields,
-dependency on an omitted recursive local, and an excessive constructor
-universe with the exact ordinary-producer errors; the omitted-local case also
-reaches and pins the strengthened pre-family rejection.
-
-**Three positive regressions, end to end.** AliasFormer (terminal alias),
-AnnotatedPi (nested recursive-Π with retained `outParam Prop`, generated
-recursor and iota rule), and `IndexedVec` (one parameter, one index, ordered
-`nil`/`cons`, identity normalization) each prove the exact successful whole
-`buildNormalizationCandidate` call, inhabit
-`ExactProducedGenerationCandidatePackage` through the generic closure, erase
-it to `ProducedGenerationCandidatePackage`, and route both the certified
-Theory transaction and the checked replay through that package. All three also
-pass the strengthened constructor-universe gate and inhabit both produced
-post-family and pre-family semantic owners. `IndexedVec` additionally proves
-that validator and candidate field FVars differ while their Theory positions
-still align. Negatives stay sharp: opaque-`outParam` whole-candidate rejection,
-truncated and reordered views, missing/extra constructors, recursive-local
-dependency, and the environment-free
+Completed-milestone narratives, hashes, and gate evidence live in this
+file's git history and the checkpoint commit messages; this section keeps
+only the current claim surface and where each piece lives.
+
+**Inductive Theory: analysis, generation, transactions.** One artifact
+path runs from the raw/view `Normalization` boundary (computed shape plus
+semantic `Normalization.WF env`) through dependent `Checked`/`CheckedBlock`
+analysis — arbitrary nonempty non-nested mutual blocks, block-wide
+target-family ordinals, generated-name uniqueness, the impredicative-Prop
+exception — into mixed generation and the four-phase block transaction:
+the public raw `addInduct` selects the block descriptor, its exact trace
+supplies atomicity, freshness, lookups, monotonicity, and `Ordered`/WF
+preservation, and the proof-carrying `GenerationCertificate`/
+`addInductCertified` and `ValidationCertificate` boundaries remain
+available (`addInductSingleton` survives only as a deprecated migration
+wrapper). The accepted slice covers parameters, per-family indices,
+direct and sibling recursion, recursive targets below Pi telescopes,
+small and subsingleton-large elimination, exact K-target metadata, and
+zero-/one-constructor generation. The consumer-neutral local-context
+core lives in `Theory/LocalContext.lean`; `Theory/Literals.lean` owns
+literal encodings, containment, primitive descriptors, and
+`VEnv.PreludeReady` — an ordered exact Bool/Nat/Char/List/String
+contract (generated recursors and iota rules for Bool/Nat/List;
+`Char`/`String` opaque behind `Char.ofNat`/`String.ofList`) that derives
+direct literal WF, is stable under ordered extension and fresh
+constants, and stays independent of `Lean.Expr`; Verify retains only
+traversal and proves its constructor result equal to the direct Theory
+encoding.
+
+**Mutual blocks.** `Normalization.BlockWF`, `CheckedBlock.WF`,
+`ValidatedBlock.WF`, and `ValidationCertificate` give arbitrary blocks an
+exact environment-indexed semantic package: shared-parameter agreement,
+one semantic result universe, staged family constants, and a complete
+source-order constructor trace including sibling recursion and recursion
+beneath Pi binders. The real Tree/TreeList and IndexedTree/IndexedTreeList
+fixtures run the ordinary kernel validators, inhabit every WF certificate,
+compare all generated metadata with the kernel field by field, and replay
+the four phase boundaries through `AddInductBlockTrace`,
+`TrEnv'.inductBlock`, and `Aligned.addInductBlock` to actual
+implementation `ConstMap`s; exact negatives pin the parameter-mismatch,
+result-universe-mismatch, and reordered-family validation phases.
+
+**Kernel parity and differential fixtures.** One integrated 14-row
+positive matrix (Nat, Bool, List, Option, Prod, Unit — honestly
+represented by the kernel's `PUnit` — Empty, Or, And, Eq, HEq, Fin,
+Vector, Acc) reruns the ordinary producer and definitionally compares
+every represented metadata field, recursor type, rule count, and iota
+RHS; the consolidated 32-row rejection matrix covers the closure,
+collision, universe/result-shape, raw/view-incoherence, normalization,
+negativity/recursive-target, field-universe, and elimination/K failure
+space. `AliasFormer`, `AliasRec`, and `NormalizationMatrix` prove
+normalization is necessary and exactly aligned across alias positions,
+with fuel-boundary, opaque, and non-defeq rejections. Elimination and
+K-target decisions retain exact operational traces differentially
+aligned with Theory generation, pinned by the
+`Eq`/`And`/`Or`/`Nat`/source-universe fixtures and the `PUnit`/`Empty`
+one-/zero-constructor boundary; Verify's `RecursorKMatches` makes a
+type-correct recursor with wrong K metadata fail alignment.
+
+**Verify refinement layer.** Checker-run certificates (`WhnfRun`,
+`CheckTypeRun`, `IsDefEqRun`, `DefEqEvidence`, `TelDefEqEvidence`,
+`NormalizedCtorRun`, `GenerationRun`) turn exact ordinary-checker
+executions into Theory typing and definitional equality. The level
+normalizer, subsumption, and equivalence layer is proved sound through
+the verified project comparator (`NormLevel.le_eval`, `geq'_wf`,
+`isEquiv_wf`) at standard-only closures with all-pairs core/project
+differentials; the constructor-universe audit's non-Prop branch keeps
+Lean's core `Level.geq` decision inside the ordinary validator's
+existing acceptance boundary. The executable candidate producer
+(`buildNormalizationCandidate`) retains recursively indexed traces,
+structurally certified annotation consumption (runtime producer
+validation, never a semantic proof field), and arbitrary-length
+dependent `Produced` witnesses. Semantic-hierarchy assembly is automatic
+under `Nonempty`: the staged owners — generation readiness, post-family
+alignment independent of fresh-FVar identities, and the executable
+pre-family replay with omitted recursive locals — close structurally on
+real metadata (`ConstructorValidityMatrix`, `PropRecursiveBoundary`)
+with nearest-kernel negatives, at the guarded transitional closure plus
+the single exact L4L-01E producer-execution witness.
+
+**End-to-end producer regressions.** AliasFormer, AnnotatedPi, and
+`IndexedVec` each prove the exact successful whole
+`buildNormalizationCandidate` call, inhabit the exact produced package
+through the generic closure, and route both the certified Theory
+transaction and the checked replay through it; `AnnotatedParam` closes
+constructor-parameter parity against real kernel metadata, with a
+well-typed but genuinely non-defeq prefix rejected at the exact
+kernel-facing error. The operational L4L-01E package authority remains
+the exact AnnotatedPi producer case. Negatives stay sharp: opaque
+annotations, truncated/reordered views, missing/extra constructors,
+recursive-local dependency, and the environment-free
 closure/universe/name/result/collision matrix.
 
-**Constructor-parameter parity.** `AnnotatedParam` is built from Lean's actual
-kernel family, constructor, recursor, and rule metadata. Its complete ordinary
-metadata call accepts the stored `outParam Type` constructor prefix against the
-annotation-consumed `Type` family local by definitional equality; a closed,
-well-typed but genuinely non-defeq prefix reaches the same check and is
-rejected with the exact kernel-facing error. Mixed generation retains the raw
-constructor surface while using checked family parameters for emitted recursor
-binders, and the resulting recursor and iota RHS are definitionally equal to
-kernel metadata. The proof-carrying transaction and real-`ConstantInfo` replay
-then establish final lookup, WF, alignment, uniqueness, and rule membership.
-The operational L4L-01E package authority remains the exact AnnotatedPi
-producer case; the parameter fixture deliberately does not claim a second
-independently assembled produced package.
-
-**Environment replay.** The sole public L4L-07 inventory contains 19
-actual-metadata transactions: all 14 fixed rows plus AliasFormer, AliasRec,
-NormalizationMatrix, AnnotatedPi, and AnnotatedParam. Every
-`SingletonReplayArtifact` carries its exact input/output `ConstMap` and `VEnv`,
-input ordering, the proof-carrying `AddInduct` transaction, final alignment,
-and derived output ordering. Fin replays over the real Nat/LT dependency
-slice; Vector replays over Nat/Eq/Array/`Array.size`, including the stored
-metadata annotation on `Array.size`'s borrowed argument. The fixed and
-normalization inventories are definitionally tied to the Theory inventories,
-and their 14/5/19 cardinalities are executable. The older `IndexedVec`
-fixture still spells indices as `Nat.zero`/`Nat.succ`, deliberately excluding
-notation's `OfNat`/`HAdd` instance closure — a reduced dependency claim, not
-full prelude replay.
-
-**Not claimed.** Nested blocks, generated patterns, projections, and the
-remaining metatheory/checker roots. The mutual fixtures prove the current
-non-nested block boundary; they do not claim the kernel's nested flattening or
-auxiliary-family transformation.
-Bare producer success is never generation-shape authority or Theory semantics.
+**Replay and the consumer certificate API.** The supported replay matrix
+executes 25 actual-metadata transactions: the 19-row L4L-07 singleton
+inventory (the 14 fixed rows plus the alias/normalization/annotation
+fixtures, with Fin and Vector replaying over their real dependency
+slices) plus the two-parameter `BiBox` dependency, both mutual tree
+blocks, and three nested blocks. Every row retains its exact
+input/output `ConstMap` and `VEnv`, input-map WF and dependency
+ordering, data-bearing transaction trace, final roles, and recursor
+lookup uniqueness. The consumer-neutral Theory API
+`VInductDecl.BlockCertificate`/`NestedBlockCertificate` reconstructs the
+raw `addInduct` result, `addInduct_le`, `addInduct_WF`, exact lookups,
+freshness, uniqueness, registered rule membership/WF, rule closure, and
+the L4L-10 recursor-pattern facts from one checked transaction; it
+imports no Verify state, `Lean.Expr`, normalization oracle, or kernel
+object, its WF root closes at the standard baseline (the rule/pattern
+root adds `Classical.choice`), and neither reaches `sorryAx`. Verify's
+unified matrix keeps one exact guarded `sorryAx`, solely through the
+separately tracked projection/refinement frontier. A separate fresh
+replay loads the 296-declaration compiled dependency closure of the
+notation-heavy fixture into an empty kernel environment and checks every
+declaration, so numerals, notation, lists, arrays, products,
+conditionals, and strings exercise real compiled prelude dependencies.
+
+**Nested inductives.** The stored Theory payload is the source
+`VInductDecl` unchanged; nested support is additive.
+`VInductDecl.nestedElimination?` (`Theory/NestedInductive.lean`) mirrors
+`ElimNestedInductive` phase for phase against caller-supplied
+environment-free target metadata, and `nestedStage3` gates acceptance by
+flattening success plus generation readiness of the flattened block
+through the unchanged block analyzers. The restoration σ (`restoreExpr`)
+rebuilds the flattened block's generation artifacts onto the
+`appendIndexAfter` inventory (`NestedBlockChecked`),
+`VEnv.addInductNested` inserts source families/constructors plus
+restored recursors/rules through the four block phases, and
+`AddInductNestedTrace`, `NestedBlockChecked.WF`, and
+`addInductNested_WF` mirror the block transaction's lemma suite through
+`Ordered` preservation. Verify proves the Theory flattening equal to the
+port's on the rose-tree, nested-indexed, and `DeepBi`/`BiBox` fixtures,
+matches kernel accept/reject on four nearest negatives, and round-trips
+the port's complete `Environment.addInductive` output against the Theory
+artifacts (payload constants, recursors, K flags, rule RHSs,
+`numNested`).
+
+All three nested fixtures also replay from real stored metadata through
+`TrEnv'.inductNested` (`Verify/Environment/NestedReplay.lean`), with
+exact freshness chains, K-flag agreement, the literal rule fold, and
+complete `NestedBlockChecked.WF` packages proved by direct concrete
+typing derivations; the package closures are the standard baseline plus
+the persistent-map container axioms and named `native_decide`
+observations — no `sorryAx` — while the full `TrEnv'` roots carry the
+usual guarded transitional checker closure. The generic σ̂ typed
+transport (`Theory/Typing/NestedTransport.lean`: the `ConstInterp`
+environment morphism and `IsDefEq.substConst` with its
+`HasType`/`IsType`/`VConstant.WF`/`VDefEq.WF` corollaries) is proved as
+the justification layer; its β-collapse bridge to the spine-collapsed
+artifact substitution on generated artifacts remains available future
+work, not a nested-coverage gap. Source nested declarations remain
+rejected by the non-nested raw analyzer; the dedicated nested analyzer
+and transaction own their flattened/restored recursors, rules, and
+replay.
+
+**Patterns.** Every certified block's iota rules are exact
+`SimplePattern.iota` patterns with RHS templates, check lists, and
+`RuleClosure` payload closedness (`Theory/Typing/InductivePattern.lean`;
+implementation-independent shape layer in `Theory/Typing/Pattern.lean`).
+The complete generic pattern-combinatorics obligations — `pat_simple`, match
+inversion with rule-index/constructor recovery, rule distinctness, and the
+`pat_uniq`/`pat_app_l`/`pat_app_l_uniq`/`pat_app_uniq` non-intersection
+laws — are proved for one certified block from the certified inventories
+at guarded `propext`/`Quot.sound`-level closures. The typed β-collapse
+layer (`Theory/Typing/InductivePatternWF.lean`: `IsDefEq.appN_lamN`,
+`varN_matches_paths`) is sorry-free, and `pat_wf` composes it into
+pattern soundness: a successful match whose parameter and index checks
+hold is definitionally equal to the instantiated RHS template, derived
+from the exact rule defeq registered by `addInduct`, with the redex
+arriving decomposed into recursor and constructor spines — precisely
+what a verified reduction site holds — at exactly the Church–Rosser
+development's transitional unique-typing closure, shedding `sorryAx`
+automatically when the joint L4L-16 closure lands. The block-local assembler
+(`Theory/Typing/InductivePatternEnv.lean`) builds environments whose
+defeq set is exactly one certified block's generated rules plus
+separately certified extension rules over a constant base
+(`assembleEnv_defeqs`, `assembleEnv_WF`), and the union pattern set
+`AssembledPat` couples the block's facts with each
+`CertifiedExtension`'s payload and beta-collapsed coverage. L4L-18B removes
+semantic soundness and raw-registration coverage from `Params`: each
+`ParRed`/`CParRed`/`WHRed.extra` step carries the exact local `IsDefEqU`
+certificate, while `Params.Extension.join` separately requires a typed
+`CRDefEq` witness for every registered raw equation. Generated iota rules and
+`quotDefEq` have kernel-checked `VExpr.stripLams` coverage, and named
+`VEnv.LE.extra`/`extra_appN` transports preserve registered tower equality
+under environment growth. No open-environment extension instance is
+installed; both fixture blocks assemble over the empty base with their defeq
+sets pinned to their generated rules.
+
+**Projections.** `Theory/Projection.lean` is the consumer-neutral
+projection boundary decided at L4L-13A/B. `VStructureView` restricts the
+same one-family `GenerationChecked` artifact used by inductive
+generation to the kernel structure class — exactly one constructor, no
+indices, no recursive fields — and retains per-field sort levels.
+Projections are recursor-encoded: `projectionCodes` computes, per field,
+a dependent motive (`typeFn`, with earlier projections substituted into
+later field types), the selecting minor, and the projector program,
+with `projectionType?`/`project?` derived. `Registered`/`WF` tie a view
+to exact environment lookups and generated iota rules, and
+`VEnv.TrProj env U Γ view levels params idx major result` demands level
+WF and arities, a well-formed parameter spine, the exact instantiated
+major type, and the computed program; syntactic determinism
+(`result_eq`) and environment extension (`mono`) are proved at
+`propext`/`Quot.sound`. Verify's `TrProj` is now a fully constrained
+compatibility wrapper (existential view/levels/params with
+`view.name = structName`; no invented metadata), so the former Tier S
+specification sorry is gone and roots that merely mention `TrExprS` no
+longer inherit `sorryAx` through the projection branch. The
+`DependentRecord` fixture — simultaneously parameterized,
+universe-polymorphic, and dependent — pins the complete encoding
+(`Tests/ProjectionExpressibility.lean`).
+
+The L4L-14 structural package is proved: weakening, inverse weakening,
+context-defeq transport, WF, uniqueness, term substitution, and universe
+instantiation retain their compatibility names and are bundled by
+`TrProj.structuralLaws`. L4L-15A proves `inferProj.WF`, both constructor and
+string branches of `reduceProj.WF`, and the enclosing WHNF/translation
+projection paths. Their exact guards distinguish the remaining inherited
+Tier-R inversion dependency from projection-specific proof debt.
+
+**Structure eta.** L4L-15B adds the registered lower-layer `VStructEta`
+descriptor, monotone `VEnv.structEtas` registry, ordered subject-reduction
+certificate, and the exact `VEnv.IsDefEq.structEta` contraction for complete
+parameter spines. The checked-view bridge fixes reconstruction to the
+deterministic recursor-encoded projector programs; `StructureEtaArtifact`
+retains the exact host family/constructor alignment and registry membership.
+Weakening, substitution, strong typing, inversion/discrimination,
+standardization, nested transport, and every environment-schema consumer
+carry the new case. `StructEq` retains oriented reconstruction
+seeds and complete typed constructor-spine congruence; its named parallel
+join records the constructor/iota, nesting, internal reduction, dependent
+field, proof/Prop, and registered-`.extra` interactions. The unconditional
+`tryEtaStructCore.WF` and `isDefEqUnitLike.WF` roots are now proved from the
+registered artifact, removing both direct Tier V sorries. Exact axiom guards
+pin registration, subject reduction, the primitive rule, Church--Rosser, and
+both roots; the executable/kernel fixture matrix covers dependent
+parameterized, zero-field, proof-field, Prop-valued, recursive,
+multi-constructor, and indexed declarations.
+
+**Theory-only consumer surface.** The L4L-15C audit moved the generic
+`SpineWF` weakening/inversion laws to `Theory/Typing/UniqueTyping.lean`,
+primitive-environment extension and Bool-literal typing to
+`Theory/Literals.lean`, constant-absence and containment facts to their
+Theory owners, and the Bool-to-elimination-mode conversion to
+`Theory/Inductive.lean`. Verify keeps only deprecated compatibility shims
+where a public name existed. `Tests/TheoryConsumerSurface.lean` imports no
+Verify module and pins the availability and exact axiom closure of every
+migrated API.
+
+**Not claimed.** The remaining metatheory/checker roots. The beta-collapsed
+certificates do not constitute the whole-live-environment
+`Params.Extension` instance; constructing it (consumed only by
+`IsDefEq.church_rosser`, and needing weakN-inversion-strength fields that
+arrive with the joint L4L-16 co-deliverables) is L4L-18A work under the 2026-08-13 re-cut, while
+L4L-16D builds the SExpr-side instances that `sort_invS` consumes. Pattern coverage,
+checks, and registry membership never imply an operational rewrite without
+the local equality certificate. The nested fixtures prove the current
+single-target, indexed, and queued deep two-parameter boundaries; nesting
+classes beyond the accepted flattened-block analyzer remain rejected. The
+296-declaration notation replay is a real fresh prelude prefix, not a claim
+that an arbitrary whole kernel environment replays. Bare producer success is
+never generation-shape authority or Theory semantics.
 
 ### 2.2 Live debt
 
 The sorry audit (`Lean4Lean/Audit/SorryFrontier.lean`, a declaration-level
 `sorryAx` allowlist over the compiled Theory/Verify surface) currently
-accepts exactly 20 live sorries across 19 declarations (`NormalEq.parRed`
-carries two), plus six deliberately kernel-rejected fixture recoveries that
-are not proof debt:
+accepts exactly 16 sorried proof declarations (`NormalEq.parRed` carries two
+tokens), plus six deliberately kernel-rejected fixture recoveries that are
+not proof debt. The compiled allowlist therefore contains 22 declarations:
 
 | Area | Live debt |
 |---|---|
-| Projection specification | `Verify/Typing/Expr.lean:67`, `TrProj` |
-| Projection structural laws | seven sites in `Verify/Typing/Lemmas.lean`: `weak'`, inverse weakening, `defeqDFC`, `wf`, `uniq`, `instN`, `instL` |
-| Core metatheory | `Injectivity.lean` x3, `UniqueTyping.lean` x1, `ChurchRosser.lean` x2 |
-| Checker verification | `Verify/Environment.lean` x1; `InferType.lean` x1; `WHNF.lean` x2; `IsDefEq.lean` x2 |
-
-The remaining v4.31-added sorry is classified:
-`Lean4Lean.addDecl.WF` → L4L-19B. Non-sorry debt:
-
-- The public inductive spec has complete one-family and non-nested mutual
-  generation, preservation, metadata parity, and environment replay, but
-  remains a growing subset rather than kernel-complete; nested,
-  generated-pattern, and projection coverage remain queued.
-- Consumer-neutral APIs (`VLocalDecl` core, literal encodings,
-  `ContainsLits`, `HasPrimitives`, `TrProj`) still live under `Verify/`,
-  forcing downstream checkers to import that layer (L4L-12A/L4L-15C).
-- 29 project-specific `axiom` declarations outside `Experimental/`: 27 in
+| Core metatheory (Tier R) | `Injectivity.lean` x3; `UniqueTyping.lean` x1; `Projection.lean` x1; `ChurchRosser.lean` x2 |
+| Checker verification (Tier V) | `Verify/Environment.lean` x2 (`addDecl.WF` — now only its `inductDecl` case — and the re-sorried `addQuot.WF`); `Boundaries.lean` x1 (upstream's `checkPrimitiveDef.WF`); `Extension.lean` x5 (the D017 checker-readiness transports); `WHNF.lean` x1; `InductiveFixtures.lean` x1 (`aliasFormerAlignmentRun` repair debt) |
+
+All Tier V entries are L4L-19A/19B territory; the eight added at the v4.33
+reconciliation are classified in ledger row D017. Non-sorry debt:
+
+- The public inductive spec has complete one-family, non-nested mutual,
+  and nested generation, preservation, metadata parity, environment
+  replay, generic iota-pattern facts, pattern soundness (`pat_wf`), and
+  the block-local pattern environment assembler. The complete supported
+  replay matrix and consumer certificate API are now closed, but the accepted
+  inductive language remains a growing subset rather than kernel-complete;
+  projection semantics landed at L4L-13A/B and projection structural/checker
+  verification closed at L4L-14/L4L-15A; structure eta and unit-like
+  comparison closed at L4L-15B as a documented divergence (ledger D019) on
+  the reconciled v4.33 base. `pat_wf` carries the Church–Rosser
+  development's transitional unique-typing closure until the joint L4L-16 closure lands.
+- The L4L-15C consumer-neutral audit is complete. Generic spine laws,
+  primitive-environment extension, literal typing, containment/absence, and
+  elimination-mode conversion now have Theory-only homes, with a dedicated
+  import-boundary/axiom audit and deprecated Verify shims only where needed.
+- 34 project-specific `axiom` declarations outside `Experimental/`: 32 in
   `Verify/Axioms.lean` and two pointer-equality contracts in `PtrEq.lean`.
-  Three cached-field equations from the group once false on older pins
-  (`lean4#8554`) remain unproved and therefore forbidden contracts even though
-  v4.31 fixed the underlying cache bug.
-- The fetched `logrel@upstream` branch at `e431dad8` is a serious experimental
-  route to injectivity/unique typing, but it depends on unfinished
-  `ShapeLogRel`/adequacy work and cannot be merged as a completed proof.
+  The v4.33 reconciliation added five upstream reference equations for core
+  level operations (`Level.normalize_eq`, `Level.mkMaxAux_eq`,
+  `Level.skipExplicit_eq`, `Level.isExplicitSubsumedAux_eq`,
+  `TreeMap.any_eq_any_toList`) consumed by upstream's `LevelStd`
+  verification. Three cached-field equations from the group once false on
+  older pins (`lean4#8554`) remain unproved and therefore forbidden
+  contracts. The 2026-08-10 dead-axiom finding shrank: upstream's merged
+  proofs use `TreeMap.all_eq_all_toList` again, so only
+  `Level.mkLevelIMaxCore_eq`, `Expr.liftLooseBVars_eq`, and `Expr.equal_eq`
+  remain deletion candidates, and their reachability must be re-run on the
+  v4.33 tree at L4L-20A before deleting. 28 of the 32 carry `@[simp]`, so
+  §3's simp ban is containment work not yet done. The L4L-13A/B `sorryAx`
+  shed moved a large population of candidate/fixture roots into the
+  sorry-free set with the cached-field trio (and other reference equations)
+  still in their closures, so enforcing the "no forbidden axiom in a
+  sorry-free supported root" CI rule waits on the actual L4L-20A retirement
+  (prove the equations for the pinned implementation or take them off the
+  trace-proof simp path).
+- `addInductSingleton` (deprecated 2026-08-07) has zero callers outside
+  its own shim block and is deletable as one self-contained block; the
+  deprecation has not yet appeared in any published checkpoint, so time
+  the removal against the consumer window.
+- `NestedBlockCertificate` exposes the full lookup/freshness/WF/rule
+  surface but no `ruleClosure`/`IotaPat` pattern facts; pattern facts are
+  block-certificate-only until the σ̂ β-collapse bridge lands (L4L-19A).
+- The semantic route to injectivity/unique typing runs through the
+  in-tree `Experimental/` `SExpr`/`ShapeLogRel` development; the route
+  and joint-route decisions live in
+  `plans/l4l-16-sort-inversion-decision.md`, the design state in
+  `plans/l4l-16-completion-plan.md`, and the measured gate path in the
+  L4L-16 ladder entry (§5). Current admission surface: the adequacy
+  iota leaf and `SExpr.WHRedS.defeq` are the two `sorryAx` sources on
+  the gate path; three further `SExpr.lean` admissions are documented
+  off-path deferrals; `ShapeLogRel.lean` is live-sorry-free. Nothing
+  there merges as a completed proof, and no experimental assumption
+  substitutes for a supported root's accepted closure.
+- `Lean4Lean.Experimental` is not among Lake's `defaultTargets`, so no §6
+  gate ever builds it. L4L-16A explicitly parked the four pre-broken,
+  unreferenced prototypes — `Stratified`, `StratifiedUntyped`, `Stronger`,
+  and `ParallelReduction` — as import-compatible stubs. Their stale source
+  targeted the pre-structure-eta/non-mutual judgment, and `Stronger` and
+  `ParallelReduction` also carried admissions; none belongs on the L4L-16
+  trust path. `Experimental/UniqueTyping.lean` was separately migrated to
+  a strong-judgment compatibility endpoint: it no longer attempts the
+  invalid recovery of lost strong evidence from weak `IsDefEq`.
 - The dev-branch flake rework scoped `leanSrc` to a fileset, retiring the
   earlier `inputs.self.outPath` source-invalidation debt; remaining flake
   debt is cosmetic. The `system` deprecation warning comes from the
@@ -358,14 +445,14 @@ migrate, not foundations. Returning assembled hierarchies under `Nonempty` is
 deliberate: it states semantic existence without using choice to extract a
 data-bearing checker-selected view.
 
-Current custom-axiom inventory (29 declarations; classification records
+Current custom-axiom inventory (34 declarations; classification records
 intended release treatment, not evidence the equations are true):
 
 | Class | Count | Declarations | Release treatment |
 |---|---:|---|---|
 | Unproved cached-field equations, once false on older pins | 3 | `Level.hasParam_eq`, `Level.hasMVar_eq`, `Expr.looseBVarRange_eq` | Forbidden from every supported theorem root until proved for the pinned implementation |
-| Reference equations documented as `@[implemented_by]` candidates | 13 | `Expr.replace_eq`, lift/lower, instantiate/range/reverse, abstract/range, `hasLooseBVar_eq`, `eqv_eq`, `equal_eq` | Replace axioms with logical reference definitions and separately justified implementations |
-| Persistent collection semantics | 5 | `TreeMap.all_eq_all_toList`; `PersistentArray.toList'_push`; hash-map insert, find, and contains/find agreement | Prove upstream or narrow to the actual WF/reachable-state invariant |
+| Reference equations documented as `@[implemented_by]` candidates | 17 | `Expr.replace_eq`, lift/lower, instantiate/range/reverse, abstract/range, `hasLooseBVar_eq`, `eqv_eq`, `equal_eq`; the v4.33 core level-operation equations `Level.normalize_eq`, `Level.mkMaxAux_eq`, `Level.skipExplicit_eq`, `Level.isExplicitSubsumedAux_eq` | Replace axioms with logical reference definitions and separately justified implementations |
+| Persistent collection semantics | 6 | `TreeMap.all_eq_all_toList`, `TreeMap.any_eq_any_toList`; `PersistentArray.toList'_push`; hash-map insert, find, and contains/find agreement | Prove upstream or narrow to the actual WF/reachable-state invariant |
 | Other opaque or representation-layout bridges | 5 | `Syntax.structEq_eq`; Level and Expr data-layout equations; `Level.mkLevelIMaxCore_eq` | Expose/prove upstream, narrow to the properties actually needed, or reject |
 | Candidate platform contracts | 3 | `ptrEqExpr_eq`, `ptrEqConstantInfo_eq`, `Level.instLawfulBEqLevel` | May remain only in a named, version-pinned platform manifest with differential tests |
 
@@ -490,231 +577,569 @@ from this ladder, with their record kept in git history. Earlier partial
 implementation counts as a prerequisite, never as partial credit. A suffixed
 identifier such as L4L-01D2 is a full checkpoint with its own commit and
 gates. Read-only design reconnaissance for a later milestone is allowed when
-it changes the active design, but implementation and publication stay serial:
-this keeps one auditable claim per checkpoint and prevents several
-half-migrated public artifact paths from being live simultaneously.
+it changes the active design. Implementation and publication normally stay
+serial; an explicitly independent later milestone may close as its own
+audited checkpoint while the active milestone waits at a mandatory external
+approval gate, provided this exception is recorded here and does not change
+the blocked semantics. L4L-15C closed under this exception while L4L-15B
+stood at the former structure-eta approval gate. This keeps one auditable
+claim per checkpoint and
+prevents several half-migrated public artifact paths from being live
+simultaneously.
 
 If upstream advances at a milestone boundary, insert an explicit
 integration-only reconciliation checkpoint (as was done for v4.31) rather
 than hiding merge work inside a semantic milestone.
 
-### Nested inductives (L4L-09A–L4L-09C)
-
-**L4L-09A — nested representation decision (active).** Audit how translated
-`inductInfo` represents flattened nested auxiliaries even though the producer
-receives `numNested` and `VInductDecl` does not. Commit a design note plus
-executable metadata probes. Choose an additive metadata/checked-block type or
-proved pre-flattening relation; change existing `VInductDecl` fields only if
-neither can express real output, with downstream compatibility evidence
-first.
-*Exit:* the design is sufficient for real rose-tree and nested-indexed
-metadata; no acceptance behavior or public field changes without demonstrated
-need; this checkpoint changes no acceptance behavior.
-
-**L4L-09B — nested transformation and positivity.** Implement the chosen
-pre-flattening/auxiliary relation, the kernel nested transformation, and its
-positivity/validation obligations.
-*Exit:* the transformed family and auxiliary descriptors for a rose tree
-through List and one nested indexed family, plus nearest rejection
-differentials, match kernel acceptance; no generated recursor or replay is
-claimed yet.
-
-**L4L-09C — nested generation and replay.** Generate every auxiliary
-declaration, recursor, and rule; prove preservation and insertion order.
-*Exit:* both fixtures round-trip real `Inductive.Add.run` output through
-generic packaging and environment replay, comparing all raw metadata and
-rule RHSs rather than a hand-authored declaration.
-
-### Generated patterns (L4L-10A–L4L-10B)
-
-**L4L-10A — generated iota pattern core.** Construct every generated iota LHS
-through `SimplePattern.iota` or prove exact equality to its `Pattern`. Prove
-match inversion, rule-index/constructor recovery, rule distinctness, pairwise
-non-intersection, and the
-`Params.pat_uniq`/`pat_app_l_uniq`/`pat_app_uniq` obligations for one
-certified block. Add the implementation-independent shape helpers
-(`HeadConst`, `HeadConstN`, `of_varN_matches`, `RecursorIotaPattern`,
-`matches_shape`) to `Theory/Typing/Pattern.lean`.
-*Exit:* a certified block supplies the complete generic pattern facts with
-standard Theory axiom closure; no open-environment instance is installed.
-
-**L4L-10B — pattern soundness and environment assembler.** Prove `pat_wf`:
-successful match/check instantiates the LHS/RHS defeq registered by
-`addInduct`. Add a block-local assembler for an environment whose defeq set
-consists of generated inductive rules plus separately certified extension
-rules.
-*Exit:* the assembler is generic over certified extensions, installs no
-global open-environment `Params` instance, and exposes exactly the helpers
-Church–Rosser and downstream consumers need.
-
-### Replay breadth and the block-certificate API (L4L-11)
-
-**L4L-11 — consumer block-certificate API.** Generalize the automatic
-candidate/package construction and environment replay across the complete
-single/mutual/nested fixture matrix, keeping every dependency environment
-explicit and checking type, every constructor role, and recursor lookup
-uniqueness. Separately add a notation-heavy prelude replay fixture before
-claiming whole-environment coverage; do not hide that prefix behind a
-hand-built Theory-only environment, and abstract witness-only tests are not
-sufficient. Export the consumer-neutral block-certificate consequences:
-environment growth (`addInduct`/`addInduct_le`), block WF
-(`VDecl.WF.induct`/`addInduct_WF`), translated type/constructor/recursor
-lookups, recursor facts from generated rule membership and registered
-defeqs, and recursor patterns from L4L-10A/B. If a downstream checker cannot
-fill a semantic obligation from these APIs without a new assumption,
-strengthen the checked-block API here rather than expecting the consumer to
-add trust.
-*Exit:* the full supported block class replays from actual metadata; the
-block-certificate API is exported with exact guards and no `sorryAx` beyond
-the separately tracked projection relation; no Verify state, normalization
-oracle, or kernel implementation object crosses the Theory boundary.
-
-### Theory API extraction and literals (L4L-12A–L4L-12B)
-
-**L4L-12A — Theory API extraction.** Split `VLocalDecl` and its VExpr-only
-operations/WF/defeq lemmas from the `FVarId`-specific `VLCtx` layer into
-`Theory/LocalContext.lean`. Move `VExpr.boolLit`, `natLit`, `listCharLit`,
-`trLiteral`, `VEnv.ContainsLits`, the implementation-independent part of
-`VEnv.HasPrimitives`, and their lift/inst/instL lemmas into
-`Theory/Literals.lean`. Keep `TrExprS` and all
-`Lean.Expr`/`Literal.toConstructor` traversal in Verify; re-export old names.
-*Exit:* the library builds through compatibility re-exports; no semantic
-assumption is removed yet; import-direction and exact axiom gates pass.
-
-**L4L-12B — literal and prelude readiness.** `ContainsLits` says only that
-names occur in the environment; it does not imply their types. Define a
-Theory-level readiness predicate combining `Ordered` with the exact
-Nat/Bool/Char/List/String constant types and required iota rules. Prove that
-readiness plus `ContainsLits l` gives `VExpr.WF env U [] (VExpr.trLiteral
-l)`; that direct `trLiteral` meaning agrees with the Verify translation of
-`Literal.toConstructor`; and that readiness is monotone under `VEnv.LE` and
-preserved by unrelated declarations.
-*Exit:* literal WF is a derived theorem from the readiness predicate;
-notation-heavy fixtures pass; no invalid name-containment shortcut is used.
-
-### Projections and structures (L4L-13A–L4L-15C)
-
-The current API needs a design gate first. `TrProj Γ structName idx e e'` has
-no environment, universe count, structure descriptor, constructor metadata,
-or projection-name map; `TrProj.uniq` is even stated for unrelated `s₁` and
-`s₂`. A recursor encoding cannot simply be dropped into that signature.
-
-**L4L-13A — projection expressibility decision.** Freeze the seven current
-lemma statements as regression tests, then check whether a meaningful
-relation can satisfy them without strengthening their premises — in
-particular structure-name dependence, parameter offsets, dependent fields,
-universe instantiation, and uniqueness. If the signature is inadequate, add a
-Theory-level env-indexed API such as a `VStructureView` plus
-`VEnv.TrProj U Γ view idx e e'`, changing Verify's `TrExprS.proj` through a
-compatibility wrapper. Do not encode the missing metadata as unconstrained
-existential witnesses.
-*Exit:* real parameterized/dependent/universe fixtures demonstrate
-representability; the API decision is recorded.
-
-**L4L-13B — projection semantics.** Default to a recursor encoding because it
-reuses generated iota rules and is consumer-neutral; compare against applying
-a registered projection-function constant, which matches Lean metadata more
-directly but requires a projection-name map in Theory. Choose the
-representation that makes all of the following derivable from one
-`VStructureView`: projection field type (including dependencies on earlier
-projections); constructor projection/iota behavior; congruence under defeq
-and environment extension; lift, substitution, and universe instantiation;
-and structure eta / zero-field behavior, or a precise statement of what
-additional Theory rule is required.
-*Exit:* the representation computes on real structures and makes every
-L4L-14 premise expressible; no structural law or checker proof is claimed
-early.
-
-**L4L-14 — projection structural laws.** Prove the seven upstream
-obligations — weakening, inverse weakening, context-defeq transport, WF,
-uniqueness, term substitution, and universe instantiation — and expose one
-bundled structural-laws theorem while preserving the individual compatibility
-theorem names for upstream Verify. Add projection-bearing end-to-end
-fixtures.
-*Exit:* the projection relation and all seven structural-law sorries are
-gone from the frontier; projection fixtures pass; compatibility names are
-preserved.
-
-**L4L-15A — projection checker verification.** Use the structure view to
-prove `inferProj.WF`, `reduceProj.WF` for constructor applications and
-strings, and the projection branches of WHNF and translation congruence.
-Re-run the enclosing `inferType`, `whnfCore`, and `isDefEq` theorems so the
-absence of a local sorry also removes it from every exported root.
-*Exit:* focused structure/string fixtures and enclosing checker roots pass
-with exact axiom closures; eta/unit-like roots remain queued.
-
-**L4L-15B — structure eta and unit-like comparison.** Derive
-`tryEtaStructCore.WF` and `isDefEqUnitLike.WF`. First attempt derivation from
-the recursor/iota package, proof irrelevance, and projection uniqueness. If
-Lean's structure eta requires a new primitive Theory defeq rule, write a
-design note covering subject reduction, injectivity, confluence, and
-downstream impact, and obtain upstream agreement before changing `IsDefEq` —
-this is a metatheory change, not a local checker lemma.
-*Exit:* both roots are sorry-free and audited; any Theory-rule change has
-subject-reduction/injectivity/confluence and downstream-impact evidence.
-
-**L4L-15C — Theory-only consumer import surface.** Audit the consumer-neutral
-lemmas still living under Verify after L4L-12B and L4L-15B; give each a
-Theory home and deprecate the corresponding Verify compatibility shims.
-*Exit:* no consumer-neutral lemma requires a `Lean4Lean.Verify` import;
-compatibility re-exports are removable without loss.
-
-### Metatheory closure (L4L-16–L4L-18B)
-
-Scheduled completion work; coordinate with Mario because upstream has active
-research branches.
-
-**L4L-16 — route selection and sort inversion.** Evaluate two routes in a
-small, focused proof branch: (1) finish and bridge the fetched
-`logrel@upstream` approach (`ShapeLogRel`, adequacy, and
-`Experimental/UniqueTyping`) into live VExpr judgments; or (2) complete the
-current stratified `HasTypeStrong` proof directly. The spike must list every
-remaining assumption in the chosen route and close the existing public
-`IsDefEqU.sort_inv` statement. Merge only that proof, its necessary generic
-lemmas, and the documented route decision — not the whole experimental
-branch, which changes unrelated code and still contains adequacy sorries.
-*Exit:* the public sorry is removed with an exact accepted axiom closure;
-the chosen and discarded routes are documented with concrete remaining
-obligations.
-
-**L4L-17 — remaining injectivity and weakening inversion.** Building on
-`sort_inv`, prove `IsDefEqU.forallE_inv_stratified`,
-`IsDefEqU.sort_forallE_inv`, and `IsDefEqU.weakN_iff`; re-run
-`IsDefEq.uniq`/`uniqU`, context inversion, and all downstream `#print
-axioms` checks.
-*Exit:* the remaining public injectivity/inversion statements are sorry-free;
-affected Theory and checker roots have exact accepted closures.
-
-**L4L-18A — Church–Rosser `.extra` cases.** The holes in `NormalEq.parRed`
-are the constant/application cases where a parallel step meets a user
-defeq-pattern step. Use the generic `Params` interface, L4L-10B's match
+### Metatheory closure (L4L-16–L4L-18A)
+
+L4L-18B completed the prerequisite interface split on 2026-08-12 (design
+note `plans/l4l-18b-extension-interface-design.md`, ledger D020).
+Identifiers are stable names carried by their deliverables; execution
+order is this list's order. This work proceeds independently of
+upstream: no milestone blocks on upstream review or interface approval,
+every interface departure is decided here and recorded, and upstream
+engagement consolidates in the L4L-20C series.
+
+**L4L-16 — semantic environment bridge, sort inversion, and joint
+inversion/uniqueness closure.** Execute the semantic route on the
+L4L-18B interface per `plans/l4l-16-sort-inversion-decision.md` (both
+resolutions). The former L4L-17 is merged in (joint route, 2026-08-13):
+the composition impossibility map showed that eliminating the
+constructor-observation closure for higher-order constructor fields
+needs a level-indexed limited uniqueness, so the inversion/uniqueness
+statements are co-proved with adequacy in one mutually founded
+development — the shape-level stratification supplies the well-founded
+structure the originally declined joint route lacked. Execution detail
+and design state live in `plans/l4l-16-completion-plan.md`; the attempt
+history is in `plans/l4l-16c-adequacy-log.md`.
+
+Measured gate path (probed against built oleans, 2026-08-13):
+`VEnv.IsDefEqU.sort_invS` closes at
+`[propext, sorryAx, Classical.choice, Quot.sound]` with no project
+axiom; the `sorryAx` sources are exactly the adequacy iota leaf and
+`SExpr.WHRedS.defeq` (consumed by the leaf machinery by dot-notation).
+`LE_Interp.sound`, `VEnv.IsDefEqStrong.mkS`, `LRS.CtorDefEq.fold`, and
+`LR.DefEq.ctor'_inv` are measured clean, and the SExpr-side
+`forallE_inv`/`sort_forallE_inv` carry `sorryAx` only through the leaf,
+so they go clean with it.
+
+- *L4L-16A — bridge interface and judgment translation.* **Complete**,
+  checkpoint `quyyrlks` (2026-08-13). *L4L-16B′ — SExpr infrastructure
+  narrowed to the gate.* **Complete**, checkpoint `pxluxmvm`
+  (2026-08-13); four Experimental admissions remain, documented
+  in-source, with `WHRedS.defeq` the only gate-path item. Narratives
+  live in the checkpoint messages and the adequacy log.
+- *L4L-16C′ — joint leaf closure (active).* In dependency order:
+  (1) the joint-induction design — state the level-indexed limited
+  uniqueness that higher-level lam-field composition consumes from its
+  predecessor, use the specialized level-one adequacy bootstrap to derive
+  the first weak-judgment alignment in a well-formed target context, restate the
+  SExpr-side inversion lemmas level-indexed (they are currently
+  top-level only), verify well-foundedness of the combined recursion,
+  and take the mk-faithfulness/reflection decision here (a VEnv-side
+  adequacy restatement must be known before the leaf closes, not
+  after); (2) chain-normalize constructor observations
+  (`CtorLink`/`CtorChain`/`toChain`) over the landed WHNF/determinism
+  layer (`WHNF.ctorSpine`, `WHRedS.ctorSpine_determ`, the mirror-spine
+  `exact` fields — checkpoints `wolxmups`, `mvmrxuus`); (3) the
+  joint weak inversion/uniqueness result at the two root constructor
+  views, closing only those `WHRedS.defeq` call sites; (4) strengthen the
+  `LRS.IotaRHSDefEq` fixed-tower contract with the head adequacy supplied
+  by well-founded recursion on semantic `R`-edges via `LE_Interp.recR`;
+  (5) fold the chain at the leaf and measure
+  `sort_invS` at `[propext, Classical.choice, Quot.sound]`, with the
+  SExpr-side inversion lemmas recorded clean simultaneously. The
+  `hDef` premise needs no 16C work (it is `IsDefEqStrong.const`'s
+  field, discharged by `mkS` from `Params.Semantic.defn`; its live
+  construction is 16D's `defn`).
+  **Status (2026-08-14):** steps (1)–(3) are kernel-checked at the
+  standard clean closure — the joint interfaces (level-indexed
+  `AdequacyAt`, contextual `JointStage`/offset `JointBuilder`, `mk`
+  reflection at `VEnv.EqUpToLevels`), the normalized constructor chain
+  (`CtorLink`/`CtorChain`/`toChain`/`foldRaw`), and the stratified
+  inversion/uniqueness bootstrap (`JointStratifiedInversion`,
+  `IsDefEq.uniq_of_stratified_inversion`,
+  `WHRed(S).defeq_of_stratified_inversion`, with contextual raw
+  uniqueness derived from level-one adequacy). Step (4) settled at the
+  proof-relevant `LE_Interp.Witness` recursion boundary after proof
+  irrelevance invalidated the paired proof-indexed recursors; the full
+  retained-typing induction (`FitsRDeep`/`SoundRDeepAt`/
+  `recNatRDeepSound`) and the admission-free dependent-application
+  core `LR.adequateApp` are kernel-checked. The D0 review then closed two
+  concrete interface gaps ahead of the live instance: weak constant-endpoint
+  universe-arity inversion and a finite proof-carrying
+  `IsDefEqStrong.defn` rule, both threaded through adequacy and building.
+  The buildP pre-mortem also found that the retained fixed-head result had
+  erased its Nat index; it is now represented by `FixedHeadResultAt`, paired
+  with same-depth `SelfAdequateAt`, and promoted to the old polymorphic result
+  only after construction at every depth. The replayable conversion-path
+  certificate and the ρ-decoupled closed-valuation leaf consumer are
+  kernel-checked (2026-08-15); the fallback legs no longer erase the
+  focused seed. The depth bootstrap landed 2026-08-15
+  (`contextualAdequacyAtDepth_of_iotaSteps`: strong Nat induction,
+  G4-clean, the level tower now a facade over the depth fixpoint),
+  conditional on one named family — the per-rung depth-indexed leaf
+  `∀ d, ContextualIotaWitnessStepAtDepth d`; the N1 peel core is
+  ported in-file. `SelfAdequateConstStep` landed the same day,
+  conditional on two named Props (`CoherentIotaLeafStep` — the chain
+  wall and home of the G4 rung audit — and `ConstDefnLocalStep`),
+  with the seed interface decided at the ambient valuation (the
+  nil-witness form proved underivable; argument journaled). Remaining
+  for step (5): **the rung audit ran on 2026-08-15 and fired the G4
+  tripwire — a structural repair is required, not another proof
+  cycle.** The chain fold's interior-vertex retyping and root subject
+  reduction demand type uniqueness at a depth no premise in scope
+  names: interior vertices are the middle terms of `CtorDefEq.trans`,
+  which retains nothing about them, so their depth is not a function
+  of the endpoints'. Neither the rung index (withheld by design — the
+  derivation induction is depth-blind) nor the rule certificates
+  (they bound the contractum, not the major) supply the bound. The
+  whole residual is now the single named, produced-and-consumed Prop
+  `LR.MajorChainFoldStep`. **The repair landed the same day**
+  (additive, zero ripple: no constructor gained a premise, no
+  structure gained a field). Its pivot was a restatement — the fold's
+  per-link uniqueness never types a `trans` middle term; after the
+  first link the anchor travels with the term, so the call reconciles
+  the link's own `SpineWF` result type against the inherited anchor.
+  Retaining that reconciliation at the constructor observation
+  (`CtorRetype`/`CtorSpineTypeUniqPath`, path-valued, SLR:11112-11147)
+  discharges the interior half outright and re-lands the whole raw
+  consumer surface without `RawTypeUniq`. **The residual has left the
+  depth-indexed fixpoint** — `CtorSpineTypeUniqPath` carries no depth
+  index and its subject is a registered declaration, so it is the
+  first residual a generation-side argument can attack. Both fields of
+  `MajorChainAnchorStep` then landed, and `rootRed` needed no
+  re-certifying subject-reduction lemma at all: retaining the
+  conversions `HasTypeStratifiedS.to_core` was discarding collapses the
+  whole discipline to Pi injectivity for type paths, `LRS.PiPathInv`.
+  `CoherentFixedHeadStep` also landed (its application fold spends
+  adequacy at `depth` — an instance the step already holds — and at
+  `depth - 1` via `isType`, so no same-rung demand), leaving three
+  named Props; the N2 premise change and the ordered telescope producer
+  are in the file, and `hcap` is now provably dead weight.
+
+  **2026-08-15 verdict — the leaf cannot close inside 16C′ as scoped.**
+  `PiPathInv` is not provable by any path-, spine-, or depth-level
+  argument: `JointPathInv.iff` shows the chain-wall repair removed
+  exactly one field (`sortPathInv`) and nothing more;
+  `PiPathInv.of_three` decomposes it into `SubjectRedS` + `PiEdgeInv` +
+  `PiHeadNorm`, the first two recoverable from it (so an equivalence
+  modulo the third); and the depth-indexed escape route is closed by
+  two independent machine-checked obstructions (the layer transport
+  needs bounded output where a rung gives bare output — the gap Prop is
+  equivalent to a *uniform* stratification bound that would make the
+  depth induction vacuous; and the chain leaf cannot supply the bounds,
+  since the anchor is manufactured from the previous link's output and
+  grows per conversion edge while chain length is unbounded; yield:
+  spines of length ≤ 1). The irreducible factor is `PiHeadNorm` =
+  `TypeWHNFEx` (a well-typed type HAS a weak-head normal form) +
+  `PiHeadStable`. **The 18A′ scoping pass then relocated the wall
+  again, and this is the current position:** `TypeWHNFEx` is NOT needed
+  — that decomposition is sufficient, not necessary, and is the
+  expensive branch. `PiHeadNorm` follows from Church–Rosser plus
+  **standardization**, transporting a Pi that already exists
+  (`PiHeadNorm.of_crLadder`); Theory already proves the analogue,
+  `VEnv.IsDefEq.reduce_forallE` (HeadReduction.lean:512) via
+  `ParRedS.standard` (:489) — a connection no plan doc had made. The
+  real wall is **sort/Pi shape disjointness**: `NormalEqPiInvL` is
+  structural in six of `NormalEq`'s eight constructors, and the
+  survivors `etaL`/`proofIrrel` cost exactly the facts Theory spends
+  the sorried `sort_forallE_inv`/`sort_inv` on. Confluence cannot
+  supply them (`proofIrrel` is a congruence with no operational
+  content), and they are unavoidable: `SortForallEDisj.of_piHeadNorm`
+  shows the leaf ENTAILS sort/Pi disjointness in four lines. **So
+  L4L-18A′ can never close the leaf on its own, however scoped**, and
+  `TypeWHNFEx` alone unblocks nothing. Scoping pass:
+  `plans/l4l-18a-prime-scope.md` (12-rung ladder, 8 of 12 already
+  machine-checked; implement by transport via `reify`, not by porting,
+  saving ~1600 lines; `Experimental/NormalEq.lean` and
+  `ParallelReduction.lean` are dead stubs recommended for deletion).
+  **That question is now answered, favourably, and the leaf has a
+  mapped non-circular closure path.** Three of the four disjointness
+  facts need NO adequacy rung: they follow from `LE_Interp.sound`,
+  which lives outside the depth fixpoint (disjointness is about head
+  shapes, which the interpretation already records; injectivity is
+  about the level, which the shape records only as a nonzero bit —
+  that is the asymmetry). The fourth, `sortInv`, is produced at rung 0,
+  because its subject is a syntactic sort and `HasTypeStratifiedS.sort'`
+  is nullary with a free depth index. All of this is landed in
+  ShapeLogRel (:14996-:15501) and the depth-0 producers in ADQ, 48
+  results, none carrying `sorryAx`, with a negative control
+  (`sortInv_bit_only`) proving soundness recovers the bit and NOT the
+  level — a sharp boundary, not a leaky one. Consequently the suspected
+  16C′ ⇄ 18A′ cycle does not exist: `PiPathInv.of_crLadder_noAdequacy`
+  closes the residual from the CR ladder alone, and rung R11
+  (`PiEdgeInv`) is proved, removing itself as an input.
+
+  **The leaf's remaining inputs, exactly:** from 18A′ —
+  `LRS.CRComplete` (Church–Rosser modulo its two `.extra` holes and the
+  live `Params.Extension` join), `ParRedSDefeq`, `PiStandard`, plus
+  `SortHeadNorm` (transport of Theory's proved `reduce_sort`); from the
+  fixpoint — `SortInv` at rung 0 only; genuinely new —
+  `LR.PiComponentTransport`, the component half of the Pi observation.
+  **CORRECTION (measured with a dependency-closure walker, superseding
+  an earlier `weakN_iff` claim recorded here): the CR-ladder route is
+  CIRCULAR and cannot close 16C′.** `ParRedS.defeq`/`.standard` do not
+  touch `weakN_iff` at all; their sorry roots are `IsDefEqU.sort_inv`
+  and `IsDefEqU.forallE_inv_stratified` — the 16C′ deliverables
+  themselves. The identification is literal, not moral:
+  `PiPathInv.of_adequacy` is definitionally `SExpr.forallE_inv`, which
+  is what `forallE_inv_stratified` promotes. So the loop closes:
+  `PiPathInv` = `SExpr.forallE_inv` ⇒ `forallE_inv_stratified` ⇒
+  `IsDefEqU.forallE_inv` ⇒ `ParRed.defeq` ⇒ `ParRedS.defeq` ⇒
+  (transport) `ParRedSDefeq` ⇒ (R11) `PiPathInv`. `PiEdgeInv.of_piPathInv`
+  is one line, making the loop sharp: R11 is a re-presentation of the
+  leaf, not a reduction to anything cheaper. The essential uses are the
+  β cases of `ParRed.defeq` (ChurchRosser:1149) and `StRed.triangle`
+  (HeadReduction:438), each reconciling an application's domain with
+  its abstraction's own domain before β can fire — textbook "subject
+  reduction for β needs Π-injectivity". The native SExpr route is NOT
+  blocked by weakening (that machinery measures clean) but hits the
+  same β case. Genuine narrowing banked: all three CR-ladder inputs are
+  used only at SORT-typed subjects (`ParRedSDefeqSort`/`CRCompleteSort`/
+  `PiStandardSort`, with `PiPathInv.of_crLadder_R12`), and the
+  narrowing provably does not dodge the hard case (an explicit
+  sort-typed β-redex witness). Note `weakN_iff` remains a real but
+  DIFFERENT obligation: it gates `church_rosser`, not these two Props.
+  **The loop is now PROVED, and the stratification escape is closed
+  too.** `LRS.piPathInv_iff_parRedSDefeq` establishes the ladder and
+  the leaf are interderivable: the native derivation
+  `PiPathInv → PatStep → ParRedSDefeq` goes through with no
+  Church–Rosser, no standardization and no adequacy (verified by a
+  dependency walker, and structurally — ShapeLogRel's 17-module import
+  closure contains none of ChurchRosser/HeadReduction/UniqueTyping/
+  Injectivity). Any proof of the rung is a proof of the leaf.
+  Three corrections came with it: the β case holds a *path* between
+  Pis, not a single edge, so the `PiEdgeInv` framing trades the leaf
+  for the L4L-17 co-deliverable via `TypeDefEqPath.collapse` rather
+  than avoiding it; there is a second, independent uniqueness site
+  (`LRS.PatStep`, from `Pattern.Action.sound` holding at the type the
+  action chose) which is NOT Π-injectivity and follows from raw type
+  uniqueness alone; and the leaf is charged at the *contraction*, not
+  the congruence — the β congruence needs no Π-inversion at all, while
+  `IsDefEq.beta` demands the argument at the abstraction's OWN domain.
+  The sort restriction does not help (sort-typedness constrains the
+  result type, never the domain — machine-checked witness in the empty
+  context). Stratification: probeS's producer-side obstruction does NOT
+  apply here (both IHs fire at the types the inversion suite returns,
+  before any path is traversed), but the consumer-side one applies
+  verbatim — the ladder must be handed an anchor manufactured from the
+  accumulated path, and that demand (`LRS.ChainAnchorAt`) is provably
+  equivalent to a uniform stratification bound. So a perfectly
+  stratified rung still could not be consumed. **Do not open the
+  stratification work.**
+
+  **Consolation, and it is substantial:** the same interderivability
+  makes the CR ladder a free downstream CONSUMER of the leaf. Landing
+  `ParRed(S).defeq_of_piPathInv` banks the whole ladder
+  (`SubjectRedS`, `PiEdgeInv`, `PiEdgeObs`, …) as a native consequence
+  that fires the moment the leaf lands — and retires the `sorryAx`
+  Theory's `ParRed.defeq`/`StRed.triangle` currently carry. The
+  inversion suite it needed (`IsDefEqStrong.app_inv'`/`.lam_inv'`/
+  `.forallE_inv_path`, ~145 lines, structural, first-try) is worth
+  landing on its own: each returns the `TypeDefEqPath` from the
+  subject's own type to the declared type, eliminating the
+  type-uniqueness fixups wherever the SExpr side inverts a typing at a
+  converted type. **Remaining route for the leaf: the joint/adequacy
+  route (`PiPathInv.of_adequacy`) — after this measurement it is the
+  only one standing.** Root cause is not `SpineWF` but
+  `LRS.ValTyPi2`/`LogRel` being `WShape`-indexed with no stratification
+  index. Closure records: `plans/probes/probeP-pipathinv.lean`,
+  `probeS-spinedepth.lean`. N2 is decided (capture-domain link on the
+  consumer's premise at the telescope's own `headTy` index).
+  Narrative:
+  `plans/l4l-16c-adequacy-log.md`; gap audit:
+  `plans/l4l-16c-buildp-premortem.md`.
+
+  **2026-08-15 (second session): the stratification lever is REFUTED
+  and the residual is renarrowed to the two root callbacks.** The
+  "missing stratification index" root-cause note is now an autopsy,
+  not a work item: `plans/l4l-16-stratified-observation-design.md` +
+  `probeT-stratpi.lean` machine-check that voucher-as-data is
+  conservative (`valTyPi2D_iff_bare`), the uniform bound is false
+  (`uniformStratBound_false` via an unbounded-minimal-depth β-redex
+  tower — and `chainAnchorAt_false`: the banked `ChainAnchorAt` Prop
+  is itself false at every depth), and a full `LogRel` re-indexing
+  inherits the wall at `trans` middles (`transMiddleCertAt_false`,
+  σ-instances unbounded). Do-not-open is now a theorem. The
+  **registered-endpoint narrowing** then landed
+  (`plans/l4l-16-registered-pi-design.md` + `probeU-regpi.lean`):
+  `PiPathInvReg` — Pi-path inversion with one endpoint a certificate
+  telescope — survives the vacuity kill-shot (the CR ladder's β site
+  has BOTH endpoints outside the registered class at every arity), and
+  `regSpine_result_uniq` (argument-list induction anchored at the
+  constructor's own telescope, replacing `SpineWF.result_path`'s
+  spine-derivation induction whose `conv` edges lose the anchor)
+  closes the entire chain-fold interior from `PiPathInvReg` alone.
+  General-`PiPathInv` demands on the leaf path drop from
+  chain-length × spine-length to exactly two — the root callbacks —
+  and both provably escape the registered class (`rootRed_meets_beta`;
+  `Pattern.Action` redex heads are never constructors). `PiPathInvReg`
+  itself is not provable by path induction (U8: the class is not
+  closed under one edge). Bankables landed the same session:
+  `IndTyHeadNorm` reclassified as banked-consumer plumbing (all five
+  consumers CR-conditional; soundness core `indTyShapeTransport`
+  landed), the RectFrame index-upgrade residual dissolved additively
+  (`CtorFrame.toRectFrame` at the recoverable `.indTy` type shape;
+  probeR13 superseded; remaining follow-up is a RectFrame at the
+  rec-app observation), and the δ-rank component has a
+  consumer-shaped design probe (`probeD-deltarank2.lean`:
+  `DeltaRankFields` + D0/D1 inhabitation with literal ranks;
+  `ConstDefnDeepInstStep` produced outright; wiring plan = a new
+  `Params.DeltaRank` class). **The typed-constructor-view probe then
+  returned verdict (ii): the map is COMPLETE**
+  (`plans/l4l-16-typedview-design.md` + `probeV-typedview.lean`, green
+  first compile, no sorryAx). Retention dissolves the root callbacks
+  as a theorem (`CtorChainT.foldRaw_of_anchorDiscipline` — `rootRed`
+  becomes projection; the residual prices at `CtorSpineTypeUniqPath` =
+  `PiPathInvReg`), but PRODUCTION of the typed view is impossible at
+  the closure laws, each failure machine-checked independently:
+  forward `whr` transport is equivalent to edge-splitting subject
+  reduction whose β instance is verbatim the leaf's `piInv` charge
+  site; backward `unwhr` transport is refuted outright
+  (`ctorViewT_unwhrClosure_false`, K-redex + `PiNotFunTyped`); and a
+  conv-closed typed view collapses all registered inductive head
+  types into one path class. The anchored variant survives every law
+  and dissolves nothing. The crown sub-question is independently
+  closed: single-EDGE inversion at a registered endpoint inherits U8
+  one level down (`regEdge_trans_middle_escapes` — a `trans` middle
+  between two registered Pis is provably unregistered and non-Pi).
+  **Consequently, with probeT (stratification), probeU (registration:
+  interior only), and probeV (retention) all machine-refuted, no
+  structural axis to the leaf remains.** The milestone choice is
+  binary: (A) re-cut 16C′ to close conditionally, parameterized on the
+  named Prop `LRS.PiPathInv` — the option `l4l-18a-prime-scope.md:448`
+  already recommends, with `CtorChainT` recorded as the consumption
+  interface the moment the Prop lands — or (B) fund the semantic
+  normalization content (a new logical-relation development for
+  subject reduction at classified spines) as its own research
+  milestone. There is no option (C).
+
+  **Decision (2026-08-15): take (A).** L4L-16C′ is re-cut as a
+  conditional closure whose semantic boundary is the already named
+  `LRS.PiPathInv`; the independent subject-reduction/normalization research
+  moves out of milestone 16/17. This is not yet permission to wrap the
+  existing leaf in that one premise: the buildP pre-mortem identified two
+  mechanical obligations still visible after the constructor-chain roots
+  consume `PiPathInv` — transport of the synchronized `RectFrame` from the
+  native constructor observation to the recursor-application result, and
+  the terminal fixed-head dominance comparison. Those remain 16C′ work and
+  stay named separately until they have real producers. The δ side of the
+  cut is now implemented: `HasTypeStratifiedR` and `Params.DeltaRank` expose
+  a strictly decreasing definition certificate; the clean
+  `ConstDefnDeepInstStep.of_deltaRank`/
+  `ConstDefnDeepStepR.of_deltaRankStage` restart bridge is axiom-pinned; and
+  D0, D1, and D2 instantiate literal ranks for every registered definition.
+  No `VEnv.WF` cycle or opaque normalization premise is hidden in that
+  interface.
+- *L4L-16D — live-environment instance.* The only route segment never
+  executed end to end — therefore staged, thin vertical slice first:
+  **D0 complete (2026-08-14, active working tree):** the generated Nat
+  fixture (both constructor iota rules) plus `d0def : Nat := Nat.zero`
+  now runs through complete SExpr `Params`/`Params.Semantic` instances
+  with `d0SortInvS` instantiated.  The D0 module is admission-free,
+  its 122-job Lake target is green, and its exact endpoint axiom closure
+  is pinned in-source; the remaining `sorryAx` is inherited from 16C′.
+  **D1 delivered 2026-08-15 except the quot semantic
+  instance:** `SExprParamsD1.lean` is admission-free — first live
+  `VDecl.WF.mutualDef`, D0→D1 transport, full `Params.Semantic`,
+  pinned `d1SortInvS`; the quot environment layer is in and pinned
+  sorryAx-free, while the quot `Params`/`Semantic` instance is blocked
+  on the Prop-wall design (the `hu0` deletion is refuted — see the
+  16E entry and `probeA1-hu0.lean`) plus
+  stuck-`Quot` injectivity of L4L-18A′ strength. **D2** ordinary/block
+  inductive rules via `AssembledPat` — the union non-overlap
+  mathematics is proved and landed in Theory 2026-08-15 (four laws +
+  cross-term engine + exact `ExtSeparation` side conditions with a
+  falsity witness; kernel `decide` only, `#guard_msgs`-pinned),
+  leaving registry consumption. **Second 2026-08-15 session:** the
+  rule-independent replay is now generic — `SExprTransport.lean` (R1:
+  syntax transport generic in `univs` agreement, proof-complete) and
+  `SExprGenericReplay.lean` (R2: the `Replay` certificate, generic
+  type-uniqueness/spine-view tower, and the sorryAx-free
+  `ruleCollapse` reify/`appN_lamN`/`mkS` chain proved once, plus the
+  `iotaSiteOf` assembler); D2 consumes them through `d1StrongToD2`
+  with unconditional `Semantic.ctor` (all five block bundles) and
+  `Semantic.defn`.  The replay boundary has since been tightened and is
+  exposed by `d2SortInvSExact` under `D2BlockStepExact`: the complete
+  ten-rule RHS registry proves descriptor subsingletonhood, and
+  `d2IotaRule_entry_elim` reduces every descriptor to the two literal Nat
+  or five literal Tree entries.  The earlier checked contract was repaired
+  to retain the actual capture typing, valid context, typed spines and
+  successful match; both Nat checks are discharged outright, so its only
+  remaining `D2TreeCheckedStep` premise is the five-rule
+  L4L-18A′-gated stuck-inductive-application injectivity.  Recursor
+  level-arity is also proved for all seven entries.  The other three exact
+  fields are the seven capture spines, seven β-collapses, and five block
+  registered towers—the per-rule volume the engine takes as input, exactly
+  as Theory's generic block-rule theorem does. The D2 environment now also carries the same
+  checked δ-rank certificate as D0/D1; block heads are irreducible at rank
+  zero and the inherited definition dependency chain is ranked literally.
+  Reduction sites do not transport downward, so the capture/collapse fields
+  still re-cover the two inherited Nat rules;
+  **D3** nested rules as registered equations only (nested pattern
+  facts stay L4L-19A); **D4** registered structure eta from the
+  L4L-15B registry certificate. Sources:
+  `classify` from block certificates, `Pat` through the D020
+  beta-collapsed coverage, non-overlap from the L4L-10B match-inversion
+  library, and the `Semantic` fields from the eta registry, generation
+  certificates, declaration history, and `IsDefEq.strong` plus beta
+  collapse. Scope: the **SExpr** instances only; the Theory-side
+  `Params`/`Params.Extension.join` live instance is consumed only by
+  `IsDefEq.church_rosser` and moves to L4L-18A.
+- *L4L-16E — promotion and joint co-deliverables.* Supported roots
+  never import experiments: the consumed modules leave `Experimental/`
+  with a stable API and a sorry-free path, the public
+  `IsDefEqU.sort_inv` closes from the instances, and the audit
+  allowlist shrinks 22 → 21. The joint co-deliverables land here from
+  the same development: `IsDefEqU.forallE_inv_stratified`,
+  `IsDefEqU.sort_forallE_inv`, `IsDefEqU.weakN_iff`,
+  `VEnv.WF.registeredStructureHeadInversion` (whose projection
+  consumers shed `sorryAx` automatically), general type uniqueness over
+  weak SExpr defeq with admissibility/elimination of the heterogeneous
+  `trans'` rule, and the re-run `IsDefEq.uniq`/`uniqU`, context
+  inversion, and downstream `#print axioms` checks. The digama
+  reconcile-or-defer decision (§7) is taken at this boundary.
+  2026-08-15 recon (checklist: `plans/l4l-16e-promotion-map.md`): both
+  co-deliverable statements already exist sorried in the trusted tree;
+  `registeredStructureHeadInversion`'s two constructor fields are
+  false as stated and need a head-classification premise before proof;
+  the `weakN_iff` forward design pass (2026-08-15,
+  `plans/l4l-16-weakn-design.md`) returned research-grade — now 2.5–5
+  weeks serial / 8–11 staged agent sessions via de-circularized
+  stratified standardization, with machine-checked obstructions
+  killing every shortcut route, the W2/W3 rungs already proved (and
+  strengthened) the same day, and the coupled `NormalEq`/CR cores
+  (W5+W6) carrying the residual risk — and recommends re-scoping it
+  plus the dependent
+  `registeredStructureHeadInversion` fields to an L4L-18A′-coupled
+  slice, decision pending; promotion is additionally gated on the four
+  off-path `SExpr.lean` sorries and the frontier-audit import
+  regeneration. The generic-instance construction behind "closes from
+  the instances" got its own design pass the same day
+  (`plans/l4l-16-generic-instance-design.md`): a conditional instance
+  is refuted as a route, the D-ladder's transport pattern *is* the
+  induction step, and the recommendation is a named successor
+  milestone **L4L-16F** rather than a 16E step or a D4 endpoint —
+  with `CtorBundle.hu0` recommended for outright deletion — **a
+  recommendation REFUTED 2026-08-15 by the executed discriminating
+  experiment** (`plans/probes/probeA1-hu0.lean`): the ADQ consumption
+  site is free, but `build_spine`'s post-deletion statement is false
+  for Prop-sorted ctor-classified pattern-argument heads, because the
+  shape algebra's proof-irrelevance law (`WShape.HasType.proofIrrel`)
+  requires `.indTy` non-Prop-sortedness and `hu0` is that law's
+  syntactic mirror. Resolving the Prop wall needs a
+  Matches/classification-level design (Prop-branch, or excluding
+  Prop-recursor iota patterns from `Pat`), so D1's quotient half stays
+  blocked on that design plus stuck-`Quot` injectivity.
+
+*Exit:* the public `sort_inv` sorry and the merged inversion/uniqueness
+statements are removed with exact accepted axiom closures — no
+`sorryAx`, no `extra_pat`-style axiom, and no environment oracle on any
+path — and the route record carries any residual semantic-route debt.
+
+**L4L-18A — Church–Rosser `.extra` cases.**
+*Promoted 2026-08-15: L4L-18A′ is a HARD DEPENDENCY of the 16C′ leaf,
+not a later cleanup — but it is not sufficient for it either.* The
+leaf's residual `LRS.PiPathInv` factors as `SubjectRedS` + `PiEdgeInv`
++ `PiHeadNorm`; the CR ladder supplies all three (`PiPathInv.of_crLadder`,
+machine-checked), with `PiHeadNorm` coming from CR + **standardization**
+rather than from any normalization theorem — `TypeWHNFEx` is not
+needed. What CR cannot supply is **sort/Pi shape disjointness**, which
+the leaf provably entails; scope that separately (see the 16C″
+recommendation in `plans/l4l-18a-prime-scope.md`, whose ladder has 12
+rungs with R1–R4 parallel-attackable and 8 of 12 already
+machine-checked). Implement by transport via `reify` rather than
+porting. Correction to `SExpr.lean:4371`: its comment claims nothing on
+the L4L-16 gate path consumes `CRDefEq.trans` — that clause is now
+false (recorded as the type-checked `LRS.crDefEq_is_on_the_gate_path`).
+Also: `SExpr.WHRedS.defeq` (:4033) is not separate work — it follows
+from `ParRedS.defeq`; and `HeadReduction.lean` is sorry-free but
+tainted three ways, one of them (via `sort_inv`/`sort_forallE_inv`)
+previously unrecorded.
+
+**2026-08-15: one hole closed, the other is FALSE as stated.** The
+`constDF` × `.extra` case is discharged (additively, `:939-1041`),
+which needed only two of the four predicted lemmas — level congruence
+for `RHS.apply` and `Check.OK` transport. The key was
+`EqUpToLevels.instL_equiv`, a purely SYNTACTIC congruence: the existing
+`EqUpToLevels.instL` demands an `IsDefEqStrong` derivation, which a
+closed `Pattern.RHS.fixed` template does not have. `EqUpToLevels` was
+also missing symmetry. The `appDF` × `.extra` case is refuted under
+`[Params]` alone by an explicit counterexample: with a `Prop`-typed
+argument position, `.app rec (.bvar 0)` is reduction-normal while
+`.app rec ctor` contracts, and NO `NormalEq` constructor relates the
+results (`structural` is uninhabited without structure-eta,
+`proofIrrel` would need the result type in `Prop`). This is not
+adversarial — Lean's own large-eliminating `Prop` inductives realize
+it (`Acc.rec`/`Eq.rec` at a `Type`-valued motive; for `Eq` the kernel
+recovers by K-style reduction, which the pattern language cannot
+express). Weakest known fix: a new semantic side condition — if a
+registered contraction's argument position is `Prop`-typed, its result
+is `Prop`-typed — i.e. a NEW `Params` field, machine-checked in
+`plans/probes/probeCR2-extra.lean` to close the whole sub-case. That
+fires §7.1 of the scope doc ("if R3 needs a new field, the estimate is
+the wrong shape"). Note the predicted blocker was wrong: proof
+irrelevance at a pattern-spine HEAD is already handled; the problem is
+at a pattern ARGUMENT.
+
+The holes in `NormalEq.parRed`
+are the constant/application cases where a parallel step meets a
+proof-carrying user-defeq pattern step. Use the generic `Params` pattern
+combinatorics, L4L-10B's match
 inversion/non-overlap library, and rule RHS congruence to prove the
-commuting diagrams, keeping the theorem generic in `[Params]`.
+commuting diagrams, keeping the theorem generic in `[Params]`. Neither hole
+requires `[Params.Extension]`: each operational step already carries its
+local equality certificate, while the global join instance is consumed only
+by `IsDefEq.church_rosser`;
+`ParRed.triangle`'s `.extra` case is the working template. The concrete
+missing lemmas: (1) `NormalEq` match inversion/spine descent — the `≡ₚ`
+analogue of the existing `ParRed` inversion, with proof irrelevance at a
+pattern-spine head the genuinely open sub-case; (2) `Check.OK` transport
+along `≡ₚ` and `≈`-equivalent level lists, extending `Check.OK.map`;
+(3) level-congruence for `RHS.apply` on closed templates under
+`Forall₂ (· ≈ ·)` — bridge `EqUpToLevels.instL` into a
+`NormalEq`/`IsDefEq` congruence; (4) routine typing side conditions at
+the transported match. The SExpr-side `CRDefEq.trans` mirror was deleted
+at the L4L-16B′ checkpoint precisely because it subsumed this milestone
+(it needed `CParRed`, `ParRed.triangle`/`church_rosser`, and
+`NormalEq.trans`, none of which exist SExpr-side): land the argument once
+against the finished Theory script here, and re-add an SExpr mirror only
+if a promoted API turns out to consume it. This milestone also owns, per
+the 2026-08-13 re-cut, constructing the Theory-side live
+`Params`/`Params.Extension.join` instance that `IsDefEq.church_rosser`
+consumes — its four structEta/forallE inversion fields are supplied by
+the joint L4L-16 co-deliverables, which is why it sits here and not in L4L-16D.
 *Exit:* `ParRed.church_rosser`, normal-form uniqueness, and the live
 standardization/head-reduction endpoints contain no hidden placeholder
 assumptions.
 
-**L4L-18B — extension contract.** Document `.extra` as the supported hook for
-consumer-certified defeqs and add the missing monotonicity/transport lemmas
-under `VEnv.LE`. State exactly what a consumer-certified extension oracle
-must prove (typedness, symmetry/closure as needed, pattern compatibility) and
-what lean4lean does not trust automatically.
-*Exit:* generic lemmas build; the consumer extension contract is documented;
-no external defeq is trusted automatically or smuggled through generated
-`Params`.
-
 ### Checker closure (L4L-19A–L4L-19C)
 
+Digama upstream carries two unabsorbed checker-side commits past the
+reconciled `b292275c` (stage-2 environment replay; enabling the new level
+algorithm — see the §2 remote-drift row) that land in exactly this
+territory. The reconcile-or-defer decision made at the L4L-16 boundary
+precedes detailed L4L-19 scoping; if deferred, repeat the check here.
+
 **L4L-19A — recursor reduction verification.** Prove `reduceRecursor.WF` for
 Quot and certified inductive rules, obtaining the selected rule, match,
 checks, RHS translation, and result typing from the generated/translated
-metadata — not from a global oracle.
+metadata — not from a global oracle. For nested blocks this requires the
+σ̂ β-collapse bridge left open in `NestedTransport` — transporting the
+flattened block's rule defeqs and pattern facts onto the restored
+`appendIndexAfter` artifacts — and extending the certificate pattern
+surface accordingly (`NestedBlockCertificate` currently exposes no
+`ruleClosure`/`IotaPat` facts).
 *Exit:* Quot, singleton, mutual, and nested recursor reductions pass;
 enclosing WHNF roots have exact guards.
 
 **L4L-19B — environment-to-checker closure.** Prove the remaining
-nonprojection checker refinements (including the v4.31 front-end
-`addDecl.WF`) and full `TrEnv` over fixture environments containing ordinary
+nonprojection checker refinements (the v4.33 front-end `addDecl.WF` — now
+only its `inductDecl` case — plus the D017 `checkPrimitiveDef.WF` and
+extension-transport entries and the re-sorried `addQuot.WF`) and full
+`TrEnv` over fixture environments containing ordinary
 declarations, Quot, single/mutual/nested inductives, literals, structures,
 and extension defeqs; state and audit the final executable-checker soundness
 theorem over this full environment class.
@@ -749,8 +1174,17 @@ stated, manifested, version-pinned, tested, absent from Theory roots;
 silent release assumption; (4) forbidden — known false on a supported
 toolchain or unproved after the implementation changed.
 
-Retire in risk order: the three remaining cached-field equations; the
-thirteen reference equations (convert to logical definitions with
+Immediate pre-work is already scoped by the 2026-08-10 audit, as amended
+2026-08-12: delete the three dead axioms (`Level.mkLevelIMaxCore_eq`,
+`Expr.liftLooseBVars_eq`, `Expr.equal_eq`); upstream's merged v4.33 proofs
+consume `TreeMap.all_eq_all_toList` again, and the unmerged
+`origin/ap/prove-treemap-all` branch would turn that axiom into a theorem
+at a future reconciliation. After the L4L-13A/B `sorryAx`
+shed the forbidden cached-field trio sits in many sorry-free closures, so
+the forbidden-axiom CI rule waits on their actual retirement rather than
+a two-root cleanup. Then retire in risk order: the three remaining
+cached-field equations; the
+remaining reference equations (convert to logical definitions with
 `@[implemented_by]` only when extensionally correct); the collection and
 opaque/layout equations (replace with upstream theorems or narrowly bounded
 WF lemmas); then decide the final platform budget explicitly (expected: the
@@ -779,9 +1213,9 @@ slice and fixtures; (4) indexed/normalization/small-elimination/
 recursive-argument support; (5) mutual and nested support; (6) the pattern
 package and Verify `AddInduct` alignment; (7) the projection structure view,
 laws, and checker proofs; (8) injectivity/Church-Rosser completion; (9) the
-remaining checker and axiom-minimization work. Do not rewrite the published
-`jcb/induct` checkpoints: each PR series is extracted onto a fresh review
-branch rebased on its current upstream target. Do not mix the large
+remaining checker and axiom-minimization work. Do not rewrite published
+`jcb/formalization2` checkpoints: each PR series is extracted onto a fresh
+review branch rebased on its current upstream target. Do not mix the large
 Nix/fork-infrastructure delta into proof PRs unless upstream asks. Record
 every PR in the divergence ledger.
 *Exit:* the final release revision is green; every fork delta is upstreamed
@@ -807,6 +1241,14 @@ The dev-branch fileset flake does not support eval-only checking
 documented at the `leanSrc` definition), so the flake gate builds for real;
 non-Linux systems stay declared but ungated, matching dev CI.
 
+Plain `lake build` covers Lake's `defaultTargets` (`Lean4Lean`,
+`lean4lean`, `Lean4Lean.Theory`, `Lean4Lean.Verify`, `Lean4Lean.Tests`);
+`Lean4Lean.Experimental` is a separate lib outside every gate and builds
+only via `lake build Lean4Lean.Experimental`. A red experiment therefore
+never blocks a checkpoint, and conversely a green gate claims nothing
+about `Experimental/` — promotion at L4L-16E is what moves the semantic
+development into the gated surface.
+
 The flake is authoritative: milestone evidence must use the pinned Nix
 toolchain and dependencies. The Lake commands above run directly from the
 already active `nix develop` shell; from outside that shell,
@@ -831,8 +1273,9 @@ Additionally:
 
 **Publication.** Publish only after the complete gate passes on one committed
 checkpoint; never publish a red or semantically split state (for example
-midway through an artifact or transaction switch). Only `origin/jcb/induct`
-moves; local/remote `master` and every digama/upstream ref stay fixed, and
+midway through an artifact or transaction switch). Only
+`origin/jcb/formalization2` moves; local/remote `master` and every
+digama/upstream ref move only at explicit reconciliation checkpoints, and
 remote-ref verification is part of each publication. Keep published
 checkpoints recoverable, and refresh the divergence ledger and sorry-frontier
 wording with each checkpoint.
@@ -852,9 +1295,11 @@ assume an oracle or axiom.
 
 ## 7. Principal risks and decision points
 
-- **Checkpoint drift.** The published `jcb/induct` line is ahead of `master`.
-  Keep published checkpoints recoverable, require Linux/Darwin CI builds at
-  release boundaries, and record any replacement hash here.
+- **Checkpoint drift.** The `jcb/formalization2` line is ahead of `master`,
+  and the local head runs ahead of `origin/jcb/formalization2` between
+  publications. Keep published checkpoints recoverable, require
+  Linux/Darwin CI builds at release boundaries, and record any replacement
+  hash here.
 - **A subset masquerading as the spec.** A sorry-free `stageN` definition can
   still be incomplete. Final acceptance is kernel coverage plus negative
   agreement, not the absence of sorries.
@@ -874,22 +1319,40 @@ assume an oracle or axiom.
 - **Raw de Bruijn scaling.** Indexed, mutual, and recursive-Pi rules multiply
   lift/inst arithmetic. Keep moving normalized evidence into the descriptor
   and telescope lemmas rather than duplicating index calculations.
-- **Projection API insufficiency.** The present `TrProj` signature may make a
-  faithful semantics impossible. Resolve L4L-13A explicitly instead of hiding
-  metadata in an oracle or preserving a false “frozen statement” rule.
-- **Structure eta may change Theory.** A new defeq constructor would affect
-  injectivity, confluence, standardization, and downstream consumers. Require
-  a design proof and upstream agreement first.
-- **Research-branch optimism.** `logrel@upstream` is evidence of a viable
-  path, not a drop-in solution; measure its remaining adequacy/bridge debt
-  with the exact live theorem as the spike gate.
+- **Structure eta changes Theory as a tracked divergence.** The new defeq
+  constructor affects injectivity, confluence, standardization, and
+  downstream consumers. The design note and ledger entry come first
+  (decision 2026-08-11); upstream review moves to the L4L-20C PR series,
+  and every reconciliation checkpoint revisits the divergence.
+- **Pattern-interface divergence.** The upstream `Params` fields
+  (`extra_pat`'s syntactic match, `pat_wf`'s bare-`HasType` premise)
+  cannot be satisfied by tower-registered environments, including
+  `quotDefEq`. L4L-18B resolves this with proof-carrying contractions,
+  beta-collapsed coverage, and `Params.Extension.join` (ledger D020).
+  The residual risks are a larger upstream-review surface at L4L-20C and
+  reconciliation conflicts wherever upstream's own `Params` and
+  experimental work move — keep the redesign minimal, ledgered, and behind
+  compatibility shims where feasible.
+- **Research-branch optimism.** The in-tree `SExpr`/`ShapeLogRel`
+  development is evidence of a viable path, not a drop-in solution. The
+  two remaining optimism hazards: the joint level-indexed
+  uniqueness-with-adequacy induction is a novel structure whose
+  well-foundedness must be verified at design time — the recorded
+  fallback is the first-order staging option in the completion plan,
+  which restores a closable milestone at reduced scope — and L4L-16D's
+  live-environment instance is the one segment of the route that has
+  never been executed end to end.
 - **Unsound bridge axioms.** Some cache equations were documented false on
   older pins and remain unproved. Zero sorries is not a soundness claim until
   final-root axiom reachability is clean.
 - **Upstream collision.** Repeat the ancestry and overlap check at every
   milestone boundary; if upstream advances again, insert another explicit
   integration checkpoint rather than hiding merge work inside a semantic
-  milestone.
+  milestone. The 2026-08-12 check found digama `upstream/master` two
+  checker-side commits past the merged `b292275c` (§2 remote-drift row);
+  the reconcile-or-defer decision is due at the L4L-16 boundary.
+  `origin/master`'s one-commit advance is already in the fork's ancestry
+  and needs no action.
 - **Scope leakage from Experimental.** No supported root may import
   experiments. Promote a proof only after removing its experimental sorries
   and giving it a stable API.
diff --git a/upstream-divergence.md b/upstream-divergence.md
index 72006f13..0af2c810 100644
--- a/upstream-divergence.md
+++ b/upstream-divergence.md
@@ -4,8 +4,8 @@ This file tracks every deliberate semantic, API, build, or verification delta
 from `upstream/master` that must either be upstreamed or explicitly retained.
 It is the tracked counterpart to `plans/roadmap.md`.
 
-Audit baseline after the complete L4L-08C mutual generation/preservation/replay
-checkpoint (2026-08-07):
+Audit baseline after the complete L4L-12B literal-readiness checkpoint
+(2026-08-10):
 
 - current upstream reconciliation parent: digama `upstream/master`
   `ef849dfbd94a`
@@ -64,17 +64,17 @@ checkpoint (2026-08-07):
   `a246c048390c7f3c3a06f87fdb94b23ef671681f`
   (`proof: establish constructor universe foundation`; 5 files changed,
   1,686 insertions, and 3,608 deletions, including the roadmap rewrite).
-  Publication to the fork's `jcb/induct` branch is pending.
+  Publication to the fork's `jcb/formalization2` branch is pending.
 - local-committed post-family constructor semantic checkpoint:
   `37d2dd998e626e25cda8874d9f6a32f85288bb91`
   (`proof: establish post-family constructor semantics`; 5 files changed,
-  3,963 insertions, and 1 deletion). Publication to the fork's `jcb/induct`
+  3,963 insertions, and 1 deletion). Publication to the fork's `jcb/formalization2`
   branch is pending.
 - local-committed pre-family constructor safety checkpoint:
   `9e40cbe00e9c6fe808ebb0720c912bba21aa1b06`
   (`proof: establish pre-family constructor safety`; 5 files changed,
   3,482 insertions, and 1 deletion; 67 commits ahead of the reconciled
-  upstream). Publication to the fork's `jcb/induct` branch is pending.
+  upstream). Publication to the fork's `jcb/formalization2` branch is pending.
 - local-committed analyzer-owned constructor view-WF checkpoint:
   `98921daf15aa` (`proof: establish analyzer-owned constructor view WF`)
 - local-committed generic singleton package checkpoint:
@@ -85,13 +85,13 @@ checkpoint (2026-08-07):
 - local-committed constructor level-comparison checkpoint:
   `de3d98c9fc5fd066b2ab88ec450e01402ed38357`
   (`proof: verify constructor level comparison`). Publication to the fork's
-  `jcb/induct` branch is pending.
+  `jcb/formalization2` branch is pending.
 - remote development checkpoints for L4L-03 at `jcb/formalization`:
   `3e6efcce` (`proof: widen D3 constructor replay`), `53d5f923`
   (`fix: emit recursors over checked parameters`), `bb883178`
   (`test: cover definitionally equal constructor parameters`), and
   `04a1a4f29de4` (`proof: certify definitionally equal parameter replay`).
-  Publication to the fork's `jcb/induct` branch is pending.
+  Publication to the fork's `jcb/formalization2` branch is pending.
 - remote development elimination/K checkpoints at `jcb/formalization`:
   `37e2ada60b04` (`proof: certify elimination mode and recursor levels`) and
   `41e1126bb587` (`proof: certify recursor K-target metadata`), followed by
@@ -103,7 +103,7 @@ checkpoint (2026-08-07):
   and `fefb93fe15e9` (`verify: replay all fixed singleton families`), followed
   by `9910e14e8cdf` (`verify: close L4L-07 singleton parity`) with the exact
   trust manifests and ledger closure.
-  Publication to the fork's `jcb/induct` branch is pending.
+  Publication to the fork's `jcb/formalization2` branch is pending.
 - remote development mutual-block checkpoints at `jcb/formalization`:
   `79e1ae4f697c` adds the L4L-08A source-indexed dependent family spine,
   shared block parameters, per-family indices/results/constructors, and
@@ -116,9 +116,27 @@ checkpoint (2026-08-07):
   `eeae5282`; the block-wide public raw transaction in `1159c655`; and the
   metadata/trust audit in `aa10005d`; this closure checkpoint adds the
   deprecated singleton migration shim and completion records.
+- local-committed nested-inductive checkpoints at `jcb/formalization2`:
+  representation and flattening from `e0ee54e` through `b8899c7`, restored
+  generation/real-output alignment from `4b3d449` through `3475370`, typed
+  constant-interpretation transport in `b71ab5c`, and the two real replay
+  closures `a77e358` and `e297560`.
+- local-committed generated-pattern checkpoints at `jcb/formalization2`:
+  the certified-block iota-pattern core `3689b11` and typed pattern soundness
+  plus the block-local environment assembler `bc51f98`.
+- L4L-11 closure checkpoint: the consumer-neutral block/nested
+  certificates, complete 25-row actual-metadata replay matrix, real queued
+  two-parameter nested replay, and 296-declaration notation-prelude replay
+  described in D013. Publication is pending.
+- L4L-12A extraction checkpoint `958d03b7`: the Theory-only local-context and
+  literal encoding APIs plus Verify compatibility re-exports described in
+  D014, based on `0587b91a`.
+- L4L-12B readiness checkpoint: the exact prelude contract, derived literal
+  WF, and Verify/direct translation agreement described in D014, layered on
+  `958d03b7`. Publication of both checkpoints is pending.
 - fixed fork master: `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb`
   on local and `origin/master`
-- current audited semantic checkpoint: the L4L-08C closure extends the
+- audited L4L-08C semantic base: the L4L-08C closure extends the
   `jcb/formalization` L4L-07 base, which integrates Nat, Bool, List, Option,
   Prod, Unit/`PUnit`,
   Empty, Or, And, Eq, HEq, Fin, Vector, and Acc into one executable kernel
@@ -200,6 +218,21 @@ checkpoint (2026-08-07):
   checkpoint. Use the branch ref, not a detached Git `HEAD`, for published-fork
   comparisons.
 
+- upstream v4.33 reconciliation checkpoint (L4L-15R, 2026-08-11): the
+  working-copy merge on `jcb/formalization2` whose second parent is digama
+  `upstream/master` `b292275c` ("perf: skip the NormLevel for levels with no
+  essential imax"; upstream advanced past the planned `1a16b72d` before the
+  merge executed, so the reconciliation took the actual head). Toolchain
+  v4.33.0 final (upstream pins v4.33.0-rc2 — see D018); lean4-nix input
+  repointed to `argumentcomputer/lean4-nix` (`fromToolchainFile` API).
+  Upstream absorbed since `ef849dfb`: verified standard-library level
+  operations (`Verify/LevelStd.lean`) plus sound-and-complete primed
+  comparators; front-end declaration checking #28 (`addDecl.WF` proved for
+  every kind except `inductDecl`, `VEnvAt`, `Environment/Checker.lean`,
+  `Extension.lean`, `Boundaries.lean`); unsafe/mutual definition blocks
+  (`TrEnv'.ignore`/`mutualDef`/`thm`); dead `cheapRec` removal; the new do
+  elaborator; and `isZero → isAlwaysZero` in inductive universe checks.
+
 Status vocabulary: `worktree`, `local-committed`, `published-fork`, `submitted`,
 `upstreamed`, or `intentional-fork`. `published-fork` means pushed to an
 Argument Computer fork branch but not yet submitted upstream. An entry is
@@ -287,10 +320,10 @@ to the replacement.
 
 ## D006 — staged computational inductive semantics
 
-- **Status:** remote-development (the earlier checkpoints are published-fork;
-  the elimination/K/edge, complete L4L-07 singleton-parity, and L4L-08C
-  mutual-generation extensions are pushed at `jcb/formalization`, while
-  publication to `jcb/induct` remains pending)
+- **Status:** remote-development (the earlier checkpoints are published-fork
+  or pushed to `jcb/formalization`; the L4L-09 through L4L-11 extensions are
+  checkpointed at `jcb/formalization2`, while publication to `jcb/formalization2`
+  remains pending)
 - **Commits:** `71f2eae`, `06e904d`, `201c12f`, `efb2a2b`, the generalized
   single-family integration in `472a6f0`, the L4L-06A/B checkpoints
   `37e2ada6` and `41e1126b`, the L4L-06C edge checkpoints `0c6b178c` and
@@ -318,9 +351,13 @@ to the replacement.
   checked/validated certificates. L4L-08C adds block-wide motive, minor,
   recursor, and rule generation; proves every artifact well formed and the
   exact four-phase transaction ordered; and replays both real mutual fixtures
-  through the implementation environment. This remains an underapproximation
-  of the full kernel: nested inductives and the later
-  generated-pattern/projection corpus are not implemented.
+  through the implementation environment. L4L-09 adds flattening/restoration,
+  generation, preservation, and real-metadata replay for the accepted nested
+  class; L4L-10 adds generated iota patterns, typed pattern soundness, and the
+  block-local assembler; L4L-11 adds the consumer certificates and complete
+  supported replay matrix recorded in D013. This remains an underapproximation
+  of the full kernel: unsupported nesting classes, projections, and the
+  remaining metatheory/checker roots are still open.
 - **Ix impact:** discharges ix gap A1's three upstream `sorryAx` origins and is
   the semantic basis for constructing `InductiveOracle`; current breadth is
   not yet enough for all ix blocks.
@@ -344,8 +381,10 @@ to the replacement.
 
 ## D007 — consumer-facing inductive transaction API
 
-- **Status:** remote-development (the one-family base is published-fork; the
-  L4L-08C block transaction is pushed at `jcb/formalization`)
+- **Status:** remote-development (the one-family base is published-fork, the
+  L4L-08C block transaction is pushed at `jcb/formalization`, and the nested
+  transaction plus L4L-11 certificate façade are checkpointed at
+  `jcb/formalization2`)
 - **Commits:** the normalized core in `472a6f0`, the proof-carrying
   non-identity API in `6a77882`, and the block transaction/public migration
   through `12040b3e`, `48882b9c`, `67d65928`, `1159c655`, and `aa10005d`
@@ -359,7 +398,9 @@ to the replacement.
   The raw `VEnv.addInduct` now selects the same block artifact and no longer
   performs singleton projection. The former one-family raw computation remains
   available as deprecated `addInductSingleton`; the normalized
-  `addInductGeneration`/`addInductCertified` APIs remain unchanged.
+  `addInductGeneration`/`addInductCertified` APIs remain unchanged. The
+  L4L-09 nested transaction and L4L-11 `BlockCertificate`/
+  `NestedBlockCertificate` consumer façade are tracked in D013.
 - **Ix impact:** lets `InductiveOracle` consume checked block results without
   unfolding `Option` binds or `foldlM`, and gives ix a Theory-only
   non-identity certificate boundary without importing Verify.
@@ -374,9 +415,9 @@ to the replacement.
 
 ## D008 — Verify inductive-environment alignment
 
-- **Status:** remote-development (the earlier checkpoints are published-fork;
-  complete L4L-07 actual-metadata execution alignment and L4L-08C mutual
-  replay are pushed at `jcb/formalization`)
+- **Status:** remote-development (the earlier checkpoints are published-fork
+  or pushed at `jcb/formalization`, and the L4L-09 nested replays plus complete
+  L4L-11 matrix are checkpointed at `jcb/formalization2`)
 - **Commits:** initial alignment in `472a6f0`, extended through `a1d8943`,
   `6a77882`, `bc37d43`, `37e2ada6`, `41e1126b`, `0c6b178c`, `df58a3a0`,
   `bb39cb2a`, `cc132cdd`, `fefb93fe`, the L4L-07 closure, and the L4L-08C
@@ -401,12 +442,16 @@ to the replacement.
   list-wide constant phases, proves fold realization and monotonicity, and
   extends `TrEnv'`/`Aligned` with an atomic mutual-block case. Both real mutual
   maps replay every family, constructor, and recursor in kernel order before
-  installing the globally flattened rules.
+  installing the globally flattened rules. L4L-09 adds the corresponding
+  restored nested trace/alignment path and two actual-metadata replays; L4L-11
+  adds final-map translated role/uniqueness lemmas, the third deep replay, and
+  the unified matrix in D013.
 - **Ix impact:** establishes the implementation-to-Theory environment bridge
   needed to translate checked inductive blocks and eventually construct
-  `InductiveOracle`; non-nested mutual replay is now closed, while nested and
-  generated-pattern/projection work is still required before that oracle is
-  constructible for the full kernel surface.
+  `InductiveOracle`. The supported singleton, mutual, and nested replay matrix
+  and generated-pattern consequences are now closed; projection semantics and
+  unsupported inductive forms still prevent construction for the full kernel
+  surface.
 - **Tests:** `lake build Lean4Lean.Verify.Environment.SingletonParityReplay`;
   executable 14/5/19 inventory equalities; every actual-metadata transaction,
   final alignment, and derived output ordering; exact Fin/Vector dependency
@@ -509,7 +554,7 @@ to the replacement.
 ## D010 — executable normalization and certified producer boundary
 
 - **Status:** remote-development (the earlier checkpoints are published-fork;
-  L4L-03 is pushed at `jcb/formalization`, while publication to `jcb/induct`
+  L4L-03 is pushed at `jcb/formalization`, while publication to `jcb/formalization2`
   remains pending)
 - **Commits:** `1fb7d6e`, `9fde4c6`, `b283912`, `a84aa19`, `c2b1c4f`,
   `a1d8943`, `6a77882`, `bc37d43`, `5e5bb76`, `33b99f4`, `a3ff992`,
@@ -813,6 +858,12 @@ to the replacement.
 - **Removal condition:** an equivalent verified fast path lands upstream, or
   the fork removes this behavior and all candidate-replay fixtures pass against
   the upstream state transition instead.
+- **v4.33 note:** upstream's new `Tests/KernelHardening.lean` fuel probe
+  assumed `checkType (deepNat 100)` consumes recursion fuel through the
+  per-argument `isDefEq` dispatch; this fast path answers those identical
+  comparisons without dispatch, so the fork's copy of the probe reduces the
+  term (`whnf`) instead of type-checking it. Same lean4#13956 property, a
+  fast-path-immune trigger.
 
 ## D012 — verified project universe-level comparison
 
@@ -852,13 +903,289 @@ to the replacement.
 - **Removal condition:** upstream provides an equivalent standard-only
   mvar-free level-order theorem and constructor semantic validation consumes it
   without a fork-only comparator.
+- **v4.33 note (partially absorbed):** upstream now verifies the standard
+  library level operations (`Verify/LevelStd.lean`) and proves the primed
+  comparators sound *and* complete with core `isEquiv`/`geq` as verified fast
+  paths, superseding this row's fork-local normalizer proofs — the merge took
+  upstream's `Level.lean`/`Verify/Level.lean` machinery wholesale. What
+  remains fork-only: routing the typechecker's sort comparison through
+  `isEquiv'` and constant-level lists through `isEquivList := all2 isEquiv'`
+  (upstream keeps core `isEquiv` on both paths); the transparent
+  `Level.isStructEq` test plus `isStructEq_eq`/`isStructEq_iff_eq` (fixture
+  consumers); and the constructor-validation bridge, which now consumes
+  upstream's `geq'_wf`/`isEquiv'_wf` instead of the retired fork lemmas.
+  Upstream's reference equations for core ops (`Level.normalize_eq`,
+  `Level.mkMaxAux_eq`, `Level.skipExplicit_eq`,
+  `Level.isExplicitSubsumedAux_eq`, `TreeMap.any_eq_any_toList`) joined
+  `Verify/Axioms.lean`, and `TreeMap.all_eq_all_toList` is live again in
+  upstream's proofs (no longer a deletable dead axiom).
+
+## D013 — complete inductive replay and consumer certificates
+
+- **Status:** remote-development at `jcb/formalization2`; publication to
+  `jcb/formalization2` is pending.
+- **Commit:** this L4L-11 closure checkpoint, based on `bc51f980`.
+- **Delta:** add the Theory-only `VInductDecl.BlockCertificate` and
+  `NestedBlockCertificate` façades over successful proof-carrying
+  transactions. They export raw transaction recovery, environment growth/WF,
+  exact family/constructor/recursor lookups and freshness, lookup uniqueness,
+  registered rule membership/WF, derived rule closure, and generated-recursion
+  pattern facts without carrying Verify state or implementation metadata.
+  Verify now preserves old implementation-map lookups across inductive folds
+  and exports exact final-map translated roles. A single 25-row inventory
+  combines 20 ordinary singleton candidate executions, both real mutual
+  blocks, and three analyzer-produced nested blocks with explicit dependency
+  maps/environments, data-bearing traces, every constructor role, and recursor
+  uniqueness. The new `DeepBi` row replays actual stored metadata over the
+  two-parameter `BiBox` dependency and exercises a queued second nested
+  occurrence, three restored recursors, and all three kernel rule RHSs. A
+  separate executable test freshly replays the real compiled dependency
+  closure of a notation-heavy fixture (296 declarations) instead of using a
+  hand-built Theory prelude.
+- **Ix impact:** downstream checkers can consume one implementation-independent
+  block certificate for growth, preservation, metadata lookup, registered
+  rules, and L4L-10 pattern consequences. The matrix demonstrates that the
+  supported singleton/mutual/nested class is constructible from actual kernel
+  metadata with dependencies kept explicit.
+- **Tests:** focused deep-nested and unified-matrix builds; aggregate
+  Theory/Verify/Tests/sorry-frontier and default Lake builds; exact 20/2/3/25
+  inventory counts and the 296-declaration fresh replay; default Nix proof and
+  dependency builds; clean-source `nix flake check`; formatter, whitespace,
+  and Theory import-boundary checks; exact compile-time axiom manifests.
+- **Axiom note:** the Theory certificate WF roots close over only `propext` and
+  `Quot.sound`; rule closure/pattern facts additionally use
+  `Classical.choice`, never `sorryAx` or a project-specific axiom. Verify's
+  translated matrix retains the already classified projection `sorryAx`,
+  pointer/expression/persistent-container contracts, existing mutual/nested
+  observations, and six narrowly named native observations for selecting the
+  singleton matrix and pinning the new deep fixture. No new `axiom`
+  declaration or source `sorry` was added, and the compiled frontier remains
+  exactly 25 allowlisted entries.
+- **Upstream issue/PR:** TBD; submit the Theory façade independently of the
+  implementation replay corpus where practical.
+- **Removal condition:** upstream exposes equivalent consumer-neutral block
+  consequences and actual-metadata replay breadth, all downstream users move
+  to it, and the fork-only certificate/matrix can be deleted.
+
+## D014 — Theory local-context and literal readiness API
+
+- **Status:** local-committed at `jcb/formalization2`; publication to
+  `jcb/formalization2` is pending.
+- **Commit:** L4L-12A extraction is `958d03b7`, based on `0587b91a`; this
+  L4L-12B readiness checkpoint is its independently gated child.
+- **Delta:** move the consumer-neutral `VLocalDecl` core and its VExpr-only
+  structural, WF, and defeq laws to `Theory/LocalContext.lean`. Move literal
+  encodings, containment, primitive descriptors, and lift/substitution laws
+  to `Theory/Literals.lean`, while keeping `Lean.Expr` traversal in Verify as
+  a compatibility surface. Add exact Bool/Nat/Char/List/String descriptors,
+  including generated recursors and iota rules, and package them with
+  `Ordered` as `VEnv.PreludeReady`. Derive typed literal expressions from
+  readiness plus the actual containment witness, preserve readiness across
+  ordered environment growth and successful fresh constant/defeq additions,
+  and connect Verify's `Literal.toConstructor` traversal to the direct Theory
+  encoding and WF result.
+- **Ix impact:** Theory-only consumers can use local declarations and typed
+  literals without importing implementation expressions or relying on name
+  containment as a type oracle. Existing Verify import paths continue to
+  re-export the moved declarations.
+- **Tests:** L4L-12A independently passed focused local-context/literal and
+  complete Verify builds plus the full release gate. L4L-12B independently
+  passes focused literal, Verify-bridge, and readiness fixture builds; exact
+  descriptor equality against kernel-checked Bool, Nat, List, Char, and String
+  metadata (including every required recursor and iota rule); large-nat and
+  Unicode-string notation fixtures; aggregate and default Lake builds;
+  unchanged 25-entry compiled sorry frontier; Nix proof and dependency builds;
+  clean-source `nix flake check`; formatter, whitespace, and Theory
+  import-boundary checks.
+- **Axiom note:** no project axiom or source `sorry` was added. New Theory
+  readiness preservation closes over only `propext` and `Quot.sound`; direct
+  literal WF additionally uses `Classical.choice`. The Verify traversal bridge
+  retains the already classified `sorryAx` inherited from its expression
+  translation frontier and is guarded separately.
+- **Upstream issue/PR:** TBD; submit the Theory extraction and exact readiness
+  contract independently from consumer-specific traversal where practical.
+- **Removal condition:** upstream provides equivalent Theory-only local-context
+  and exact typed-literal readiness APIs, Verify consumers migrate to them,
+  and the compatibility-only fork delta can be deleted.
+
+## D015 — consumer-neutral projection semantics
+
+- **Status:** local-committed (L4L-13A/B through L4L-15A checkpoints);
+  publication is pending
+- **Delta:** `Theory/Projection.lean` is a new consumer-neutral projection
+  boundary: `VStructureView` restricts the one-family `GenerationChecked`
+  artifact to the kernel structure class, `projectionCodes` encodes projections
+  as recursor programs with dependent motives, and
+  `VEnv.TrProj env U Γ view levels params idx major result` is the registered
+  projection judgment with syntactic determinism, environment monotonicity, the
+  L4L-14 structural-law bundle (`TrProj.structuralLaws`), and the staged
+  structure-eta typing infrastructure (`etaRebuild`,
+  `etaRebuild_hasType_of_constructorPrefix`). Verify's `TrProj` became a fully
+  constrained existential wrapper over the Theory judgment (no invented
+  metadata), and `inferProj.WF`/`reduceProj.WF` are proved against it.
+  Upstream has no counterpart; its projection handling is unverified executable
+  code only.
+- **Ix impact:** downstream checkers obtain a concrete projection-laws package
+  from published Theory APIs alone.
+- **Tests:** `Tests/ProjectionExpressibility.lean` (`DependentRecord`),
+  `Tests/StructureEtaCapability.lean`, `Tests/TheoryConsumerSurface.lean`, and
+  the projection-reduction paths of the L4L-15A WHNF proofs.
+- **Axiom note:** Theory roots close at `propext`/`Quot.sound`
+  (`Classical.choice` where staged); no new axiom.
+- **Upstream issue/PR:** TBD — PR 7 of the planned L4L-20C series.
+- **Removal condition:** upstream adopts the projection structure view, laws,
+  and checker proofs (or an agreed equivalent) and consumers migrate.
+
+## D016 — executable checker refactors for verification
+
+- **Status:** local-committed; publication is pending
+- **Delta:** behavior-preserving reshapes of executable checker code so exact
+  proofs can name its intermediate steps: `inferProj` uses extracted
+  `invalidProj`/`inferProjParams`/`inferProjFields` helpers and adds the
+  `isProjectionReadyStructure` and `idx < ctorInfo.numFields` guards (error
+  path only); `tryEtaStructCore`'s field loop is the named
+  `tryEtaStructFieldStep` callback; `whnfCore`/`reduceNative`/`reduceNat` use
+  the transparent `Expr.structuralEq` where upstream uses the `BEq` `==`; and
+  `checkConstructors` iterates families through the named
+  `checkConstructorsLoop` recursion instead of `for`-notation (the v4.33 do
+  elaborator synthesizes membership proofs that block exact-run rewriting).
+- **Ix impact:** none directly; keeps checker-run certificates replayable.
+- **Tests:** the executable-mirror fixtures in `Inductive/ValidationTrace.lean`
+  and `Verify/Environment/*Replay*.lean`; kernel differential matrices.
+- **Axiom note:** no new axiom; the guards reject strictly more, never accept
+  more.
+- **Upstream issue/PR:** TBD; mostly mechanical, submit alongside the proofs
+  that need each reshape.
+- **Removal condition:** upstream adopts the reshapes or the proofs stop
+  needing named intermediate steps.
+
+## D017 — checker readiness meets the v4.33 front-end chains
+
+- **Status:** intentional-fork (transitional), created by the v4.33
+  reconciliation
+- **Delta:** this fork's `VContext`/`VEnvs.WF` carry `ProjectionReady` and,
+  since L4L-15B, registered `StructureEtaReady` obligations that upstream's
+  newly proved front-end declaration chains (#28) do not establish. The merge
+  added the projection field to upstream's `VEnvAt`; L4L-15B paired the exact
+  same five transitional declarations with structure-eta readiness, without
+  adding or renaming a frontier entry. Both fields are supplied honestly by
+  `VEnvs.WF.toVEnvAt`; their extension-transport obligations remain the five
+  named Tier V sorries (`VEnvAt.addAxioms._f`,
+  `addConstCore.WF`, `addDef.WF`, `addMutualBlock.WF`, `addUnsafeDef.WF`).
+  Upstream's vacuous quotient-initialization proof (`checkEqType.WF` via
+  `TrEnv'.no_inductInfo`) is refutable on this fork — the inductive boundary
+  is implemented, so a translated environment can contain the real `Eq` — and
+  was deleted; `addQuot.WF` is re-sorried with its true statement.
+  `TrEnv'.sf_mono` was deleted (upstream's `ignore` constructor makes blanket
+  safety-lowering unsound); the fixture `TrEnv'` derivations are now stated
+  parametrically in `safety` instead.
+- **Ix impact:** none; `addDecl`-chain roots were transitional premerge and
+  remain transitional, now at finer grain.
+- **Tests:** the sorry-frontier audit pins all six entries exactly.
+- **Axiom note:** no new axiom; six new classified `sorryAx` entries
+  (L4L-19B territory), plus upstream's `checkPrimitiveDef.WF` boundary.
+- **Upstream issue/PR:** not applicable upstream (the obligation is
+  fork-only); resolved by the L4L-19B transport proofs.
+- **Removal condition:** L4L-19B proves both readiness transports across
+  `Environment.add`/`addConsts`, registers every newly completed eligible
+  structure artifact, and proves constructive quotient initialization,
+  emptying the six entries.
+
+## D018 — v4.33.0 final toolchain (upstream pins v4.33.0-rc2)
+
+- **Status:** intentional-fork (temporary)
+- **Delta:** `lean-toolchain` pins `leanprover/lean4:v4.33.0` and batteries
+  `v4.33.0` because `argumentcomputer/lean4-nix` vendors released toolchains
+  only; upstream pins `v4.33.0-rc2`.
+- **Removal condition:** upstream bumps to the final release (expected
+  imminently); no code delta is attached to this row.
+
+## D019 — registered structure eta in Theory
+
+- **Status:** implemented intentional fork divergence; L4L-15B completed on
+  the reconciled v4.33 base (2026-08-11).
+- **Owner:** John C. Burnham; semantic review is part of the L4L-20C PR
+  series.
+- **Delta:** extend Theory with an explicit environment-registered
+  structure-eta descriptor and a typed `VEnv.IsDefEq.structEta` rule for the
+  same nonrecursive, single-constructor, zero-index structures accepted by
+  Lean's kernel. The descriptor fixes the family and constructor heads and
+  the deterministic recursor-encoded projector list, and carries syntactic
+  lift/substitution laws. Registration is monotone and ordered; the equality
+  constructor retains an exact family parameter spine and both endpoint
+  typings. The complete design and case inventory are recorded in
+  `plans/l4l-15-structure-eta-design.md`.
+- **Downstream impact:** every exhaustive `IsDefEq` consumer gains a case,
+  including strong typing/inversion, weakening and substitution, environment
+  monotonicity, Church--Rosser/parallel reduction, head standardization,
+  nested transport, and the Verify structure-artifact bridge. Downstream
+  Theory consumers see an additive descriptor/registry API and one additional
+  definitional-equality constructor.
+- **Tests:** executable metadata and kernel-conversion fixtures cover
+  dependent parameterized neutral majors, parameterized zero-field,
+  proof-field, and Prop-valued positives plus recursive, multi-constructor,
+  and indexed negatives. Exact axiom guards cover registration, subject
+  reduction, the primitive rule, Church--Rosser, `tryEtaStructCore.WF`, and
+  `isDefEqUnitLike.WF`; the latter two left the direct sorry frontier, reducing
+  it from 24 to 22 entries. The full release gate is green.
+- **Axiom note:** no new project axiom or source `sorry` is permitted. Existing
+  L4L-16--L4L-18 frontier dependencies remain explicit in per-root manifests.
+- **Parallel upstream conversation:** implementation is intentionally allowed
+  to proceed in the fork as of 2026-08-11; upstream review is deferred to the
+  L4L-20C proof-PR sequence. Record the issue/PR URL here when opened.
+- **Removal condition:** upstream adopts the registered rule or an agreed
+  equivalent and the fork migrates. If upstream rejects a Theory eta rule,
+  disable the two executable structure-eta heuristics and remove this
+  divergence rather than retaining an unsound verifier claim.
+
+## D020 — proof-carrying extension reductions and beta-collapsed coverage
+
+- **Status:** implemented intentional fork divergence; L4L-18B completed on
+  the reconciled v4.33 base (2026-08-12).
+- **Owner:** John C. Burnham; semantic review is part of the L4L-20C PR
+  series.
+- **Delta:** split upstream's combined `Params.pat_wf`/`extra_pat` contract
+  into three explicit layers. `Params` retains only pattern combinatorics;
+  every `ParRed`/`CParRed`/`WHRed.extra` contraction carries an exact
+  `IsDefEqU` certificate for its concrete redex and instantiated payload;
+  and `Params.Extension.join` is a separate consumer-supplied `CRDefEq`
+  obligation for every raw registered equation in every well-formed context.
+  `CertifiedExtension.covers` records only a match after `VExpr.stripLams`,
+  where generated iota and quotient tower bodies actually expose a
+  first-order pattern. The full rationale and trust matrix are in
+  `plans/l4l-18b-extension-interface-design.md`.
+- **Downstream impact:** Church--Rosser and head standardization transport the
+  local equality certificate through weakening, substitution, context
+  conversion, match inversion, and triangle proofs. Only results that invoke
+  raw registered-equation Church--Rosser require `[Params.Extension]`.
+  `VEnv.LE.extra`, `extra_appN`, and `extra_appN_symm` publish the environment
+  growth boundary. L4L-16 must construct the whole-live-environment join
+  instance through the semantic bridge; the block assembler intentionally
+  does not synthesize one.
+- **Tests:** exact guards cover universe-instantiation of matches, the
+  generated-iota and `quotDefEq` beta-collapsed certificates, and all three
+  `VEnv.LE` transport helpers. Concrete mutual-block and quotient fixtures
+  compile the tower obligations. Focused Church--Rosser, head-reduction, and
+  pattern-environment builds plus the full release gate cover migrated
+  consumers.
+- **Axiom note:** no new project axiom or source `sorry` is permitted. The
+  concrete tower witnesses have only the standard logical baseline and no
+  `sorryAx`; existing L4L-16--L4L-18 proof-frontier dependencies are unchanged
+  and remain visible in their existing guards.
+- **Parallel upstream conversation:** implementation proceeds in the fork as
+  decided on 2026-08-12; upstream review is deferred to the L4L-20C proof-PR
+  sequence. Record the issue/PR URL here when opened.
+- **Removal condition:** upstream adopts the proof-carrying contraction plus
+  explicit registered-equation join split, or an equivalent interface that
+  represents beta-collapsed tower rules without a trusted shape or soundness
+  oracle, and the fork migrates.
 
 ## Review checklist
 
 At each publish or ix pin boundary:
 
 1. Refresh both baseline hashes and
-   `git log upstream/master..jcb/induct`; do not use a detached `HEAD` as the
+   `git log upstream/master..jcb/formalization2`; do not use a detached `HEAD` as the
    published-fork baseline.
 2. Add an entry before landing any new semantic/API delta.
 3. Record the upstream issue or PR as soon as one exists.